1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Contracts
; use Contracts
;
37 with Csets
; use Csets
;
38 with Debug
; use Debug
;
39 with Einfo
; use Einfo
;
40 with Einfo
.Entities
; use Einfo
.Entities
;
41 with Einfo
.Utils
; use Einfo
.Utils
;
42 with Elists
; use Elists
;
43 with Errout
; use Errout
;
44 with Exp_Dist
; use Exp_Dist
;
45 with Exp_Util
; use Exp_Util
;
46 with Expander
; use Expander
;
47 with Freeze
; use Freeze
;
48 with Ghost
; use Ghost
;
49 with GNAT_CUDA
; use GNAT_CUDA
;
50 with Gnatvsn
; use Gnatvsn
;
52 with Lib
.Writ
; use Lib
.Writ
;
53 with Lib
.Xref
; use Lib
.Xref
;
54 with Namet
.Sp
; use Namet
.Sp
;
55 with Nlists
; use Nlists
;
56 with Nmake
; use Nmake
;
57 with Output
; use Output
;
58 with Par_SCO
; use Par_SCO
;
59 with Restrict
; use Restrict
;
60 with Rident
; use Rident
;
61 with Rtsfind
; use Rtsfind
;
63 with Sem_Aux
; use Sem_Aux
;
64 with Sem_Ch3
; use Sem_Ch3
;
65 with Sem_Ch6
; use Sem_Ch6
;
66 with Sem_Ch7
; use Sem_Ch7
;
67 with Sem_Ch8
; use Sem_Ch8
;
68 with Sem_Ch12
; use Sem_Ch12
;
69 with Sem_Ch13
; use Sem_Ch13
;
70 with Sem_Disp
; use Sem_Disp
;
71 with Sem_Dist
; use Sem_Dist
;
72 with Sem_Elab
; use Sem_Elab
;
73 with Sem_Elim
; use Sem_Elim
;
74 with Sem_Eval
; use Sem_Eval
;
75 with Sem_Intr
; use Sem_Intr
;
76 with Sem_Mech
; use Sem_Mech
;
77 with Sem_Res
; use Sem_Res
;
78 with Sem_Type
; use Sem_Type
;
79 with Sem_Util
; use Sem_Util
;
80 with Sem_Warn
; use Sem_Warn
;
81 with Stand
; use Stand
;
82 with Sinfo
; use Sinfo
;
83 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
84 with Sinfo
.Utils
; use Sinfo
.Utils
;
85 with Sinfo
.CN
; use Sinfo
.CN
;
86 with Sinput
; use Sinput
;
87 with Stringt
; use Stringt
;
88 with Strub
; use Strub
;
89 with Stylesw
; use Stylesw
;
91 with Targparm
; use Targparm
;
92 with Tbuild
; use Tbuild
;
94 with Uintp
; use Uintp
;
95 with Uname
; use Uname
;
96 with Urealp
; use Urealp
;
97 with Validsw
; use Validsw
;
98 with Warnsw
; use Warnsw
;
100 with System
.Case_Util
;
102 package body Sem_Prag
is
104 ----------------------------------------------
105 -- Common Handling of Import-Export Pragmas --
106 ----------------------------------------------
108 -- In the following section, a number of Import_xxx and Export_xxx pragmas
109 -- are defined by GNAT. These are compatible with the DEC pragmas of the
110 -- same name, and all have the following common form and processing:
113 -- [Internal =>] LOCAL_NAME
114 -- [, [External =>] EXTERNAL_SYMBOL]
115 -- [, other optional parameters ]);
118 -- [Internal =>] LOCAL_NAME
119 -- [, [External =>] EXTERNAL_SYMBOL]
120 -- [, other optional parameters ]);
122 -- EXTERNAL_SYMBOL ::=
124 -- | static_string_EXPRESSION
126 -- The internal LOCAL_NAME designates the entity that is imported or
127 -- exported, and must refer to an entity in the current declarative
128 -- part (as required by the rules for LOCAL_NAME).
130 -- The external linker name is designated by the External parameter if
131 -- given, or the Internal parameter if not (if there is no External
132 -- parameter, the External parameter is a copy of the Internal name).
134 -- If the External parameter is given as a string, then this string is
135 -- treated as an external name (exactly as though it had been given as an
136 -- External_Name parameter for a normal Import pragma).
138 -- If the External parameter is given as an identifier (or there is no
139 -- External parameter, so that the Internal identifier is used), then
140 -- the external name is the characters of the identifier, translated
141 -- to all lower case letters.
143 -- Note: the external name specified or implied by any of these special
144 -- Import_xxx or Export_xxx pragmas override an external or link name
145 -- specified in a previous Import or Export pragma.
147 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
148 -- named notation, following the standard rules for subprogram calls, i.e.
149 -- parameters can be given in any order if named notation is used, and
150 -- positional and named notation can be mixed, subject to the rule that all
151 -- positional parameters must appear first.
153 -- Note: All these pragmas are implemented exactly following the DEC design
154 -- and implementation and are intended to be fully compatible with the use
155 -- of these pragmas in the DEC Ada compiler.
157 --------------------------------------------
158 -- Checking for Duplicated External Names --
159 --------------------------------------------
161 -- It is suspicious if two separate Export pragmas use the same external
162 -- name. The following table is used to diagnose this situation so that
163 -- an appropriate warning can be issued.
165 -- The Node_Id stored is for the N_String_Literal node created to hold
166 -- the value of the external name. The Sloc of this node is used to
167 -- cross-reference the location of the duplication.
169 package Externals
is new Table
.Table
(
170 Table_Component_Type
=> Node_Id
,
171 Table_Index_Type
=> Int
,
172 Table_Low_Bound
=> 0,
173 Table_Initial
=> 100,
174 Table_Increment
=> 100,
175 Table_Name
=> "Name_Externals");
177 -------------------------------------
178 -- Local Subprograms and Variables --
179 -------------------------------------
181 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
182 -- This routine is used for possible casing adjustment of an explicit
183 -- external name supplied as a string literal (the node N), according to
184 -- the casing requirement of Opt.External_Name_Casing. If this is set to
185 -- As_Is, then the string literal is returned unchanged, but if it is set
186 -- to Uppercase or Lowercase, then a new string literal with appropriate
187 -- casing is constructed.
189 procedure Analyze_If_Present_Internal
193 -- Inspect the remainder of the list containing pragma N and look for a
194 -- pragma that matches Id. If found, analyze the pragma. If Included is
195 -- True, N is included in the search.
197 procedure Analyze_Part_Of
201 Encap_Id
: out Entity_Id
;
202 Legal
: out Boolean);
203 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
204 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
205 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
206 -- package instantiation. Encap denotes the encapsulating state or single
207 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
208 -- the indicator is legal.
210 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
211 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
212 -- Query whether a particular item appears in a mixed list of nodes and
213 -- entities. It is assumed that all nodes in the list have entities.
215 procedure Check_Postcondition_Use_In_Inlined_Subprogram
217 Spec_Id
: Entity_Id
);
218 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
219 -- Precondition, Refined_Post, Subprogram_Variant, and Test_Case. Emit a
220 -- warning when pragma Prag is associated with subprogram Spec_Id subject
221 -- to Inline_Always, assertions are enabled and inling is done in the
224 procedure Check_State_And_Constituent_Use
228 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
229 -- Global and Initializes. Determine whether a state from list States and a
230 -- corresponding constituent from list Constits (if any) appear in the same
231 -- context denoted by Context. If this is the case, emit an error.
233 procedure Contract_Freeze_Error
234 (Contract_Id
: Entity_Id
;
235 Freeze_Id
: Entity_Id
);
236 -- Subsidiary to the analysis of pragmas Contract_Cases, Exceptional_Cases,
237 -- Part_Of, Post, Pre and Subprogram_Variant. Emit a freezing-related error
238 -- message where Freeze_Id is the entity of a body which caused contract
239 -- freezing and Contract_Id denotes the entity of the affected contstruct.
241 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
242 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
243 -- Prag that duplicates previous pragma Prev.
245 function Find_Encapsulating_State
247 Constit_Id
: Entity_Id
) return Entity_Id
;
248 -- Given the entity of a constituent Constit_Id, find the corresponding
249 -- encapsulating state which appears in States. The routine returns Empty
250 -- if no such state is found.
252 function Find_Related_Context
254 Do_Checks
: Boolean := False) return Node_Id
;
255 -- Subsidiary to the analysis of pragmas
258 -- Constant_After_Elaboration
263 -- Find the first source declaration or statement found while traversing
264 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
265 -- set, the routine reports duplicate pragmas. The routine returns Empty
266 -- when reaching the start of the node chain.
268 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
269 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
270 -- original one, following the renaming chain) is returned. Otherwise the
271 -- entity is returned unchanged. Should be in Einfo???
273 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
274 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
275 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
276 -- value of type SPARK_Mode_Type.
278 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
279 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
280 -- Determine whether dependency clause Clause is surrounded by extra
281 -- parentheses. If this is the case, issue an error message.
283 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
284 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
285 -- pragma Depends. Determine whether the type of dependency item Item is
286 -- tagged, unconstrained array, unconstrained record or a record with at
287 -- least one unconstrained component.
289 procedure Record_Possible_Body_Reference
290 (State_Id
: Entity_Id
;
292 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
293 -- Global. Given an abstract state denoted by State_Id and a reference Ref
294 -- to it, determine whether the reference appears in a package body that
295 -- will eventually refine the state. If this is the case, record the
296 -- reference for future checks (see Analyze_Refined_State_In_Decls).
298 procedure Resolve_State
(N
: Node_Id
);
299 -- Handle the overloading of state names by functions. When N denotes a
300 -- function, this routine finds the corresponding state and sets the entity
301 -- of N to that of the state.
303 procedure Rewrite_Assertion_Kind
305 From_Policy
: Boolean := False);
306 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
307 -- then it is rewritten as an identifier with the corresponding special
308 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
309 -- and Check_Policy. If the names are Precondition or Postcondition, this
310 -- combination is deprecated in favor of Assertion_Policy and Ada2012
311 -- Aspect names. The parameter From_Policy indicates that the pragma
312 -- is the old non-standard Check_Policy and not a rewritten pragma.
314 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
315 -- Place semantic information on the argument of an Elaborate/Elaborate_All
316 -- pragma. Entity name for unit and its parents is taken from item in
317 -- previous with_clause that mentions the unit.
319 procedure Validate_Compile_Time_Warning_Or_Error
322 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
323 -- pragma N. Called when the pragma is processed as part of its regular
324 -- analysis but also called after calling the back end to validate these
325 -- pragmas for size and alignment appropriateness.
327 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
);
328 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
329 -- expression is not known at compile time during the front end. This
330 -- procedure makes an entry in a table. The actual checking is performed by
331 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
334 Dummy
: Integer := 0;
335 pragma Volatile
(Dummy
);
336 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
339 pragma No_Inline
(ip
);
340 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
341 -- is just to help debugging the front end. If a pragma Inspection_Point
342 -- is added to a source program, then breaking on ip will get you to that
343 -- point in the program.
346 pragma No_Inline
(rv
);
347 -- This is a dummy function called by the processing for pragma Reviewable.
348 -- It is there for assisting front end debugging. By placing a Reviewable
349 -- pragma in the source program, a breakpoint on rv catches this place in
350 -- the source, allowing convenient stepping to the point of interest.
352 ------------------------------------------------------
353 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
354 ------------------------------------------------------
356 -- The following table collects pragmas Compile_Time_Error and Compile_
357 -- Time_Warning for validation. Entries are made by calls to subprogram
358 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
359 -- Validate_Compile_Time_Warning_Errors does the actual error checking
360 -- and posting of warning and error messages. The reason for this delayed
361 -- processing is to take advantage of back-annotations of attributes size
362 -- and alignment values performed by the back end.
364 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
365 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
366 -- will already have modified all Sloc values if the -gnatD option is set.
368 type CTWE_Entry
is record
370 -- Source location used in warnings and error messages
373 -- Pragma Compile_Time_Error or Compile_Time_Warning
376 -- The scope which encloses the pragma
379 package Compile_Time_Warnings_Errors
is new Table
.Table
(
380 Table_Component_Type
=> CTWE_Entry
,
381 Table_Index_Type
=> Int
,
382 Table_Low_Bound
=> 1,
384 Table_Increment
=> 200,
385 Table_Name
=> "Compile_Time_Warnings_Errors");
387 -------------------------------
388 -- Adjust_External_Name_Case --
389 -------------------------------
391 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
395 -- Adjust case of literal if required
397 if Opt
.External_Name_Exp_Casing
= As_Is
then
401 -- Copy existing string
407 for J
in 1 .. String_Length
(Strval
(N
)) loop
408 CC
:= Get_String_Char
(Strval
(N
), J
);
410 if Opt
.External_Name_Exp_Casing
= Uppercase
411 and then CC
in Get_Char_Code
('a') .. Get_Char_Code
('z')
413 Store_String_Char
(CC
- 32);
415 elsif Opt
.External_Name_Exp_Casing
= Lowercase
416 and then CC
in Get_Char_Code
('A') .. Get_Char_Code
('Z')
418 Store_String_Char
(CC
+ 32);
421 Store_String_Char
(CC
);
426 Make_String_Literal
(Sloc
(N
),
427 Strval
=> End_String
);
429 end Adjust_External_Name_Case
;
431 --------------------------------------------
432 -- Analyze_Always_Terminates_In_Decl_Part --
433 --------------------------------------------
435 procedure Analyze_Always_Terminates_In_Decl_Part
437 Freeze_Id
: Entity_Id
:= Empty
)
439 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
440 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
441 Arg1
: constant Node_Id
:=
442 First
(Pragma_Argument_Associations
(N
));
444 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
445 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
446 -- Save the Ghost-related attributes to restore on exit
449 Restore_Scope
: Boolean := False;
452 -- Do not analyze the pragma multiple times
454 if Is_Analyzed_Pragma
(N
) then
458 if Present
(Arg1
) then
460 -- Set the Ghost mode in effect from the pragma. Due to the delayed
461 -- analysis of the pragma, the Ghost mode at point of declaration and
462 -- point of analysis may not necessarily be the same. Use the mode in
463 -- effect at the point of declaration.
467 -- Ensure that the subprogram and its formals are visible when
468 -- analyzing the expression of the pragma.
470 if not In_Open_Scopes
(Spec_Id
) then
471 Restore_Scope
:= True;
473 if Is_Generic_Subprogram
(Spec_Id
) then
474 Push_Scope
(Spec_Id
);
475 Install_Generic_Formals
(Spec_Id
);
477 Push_Scope
(Spec_Id
);
478 Install_Formals
(Spec_Id
);
482 Errors
:= Serious_Errors_Detected
;
483 Preanalyze_Assert_Expression
(Expression
(Arg1
), Standard_Boolean
);
485 -- Emit a clarification message when the expression contains at least
486 -- one undefined reference, possibly due to contract freezing.
488 if Errors
/= Serious_Errors_Detected
489 and then Present
(Freeze_Id
)
490 and then Has_Undefined_Reference
(Expression
(Arg1
))
492 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
495 if Restore_Scope
then
499 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
502 Set_Is_Analyzed_Pragma
(N
);
504 end Analyze_Always_Terminates_In_Decl_Part
;
506 -----------------------------------------
507 -- Analyze_Contract_Cases_In_Decl_Part --
508 -----------------------------------------
510 -- WARNING: This routine manages Ghost regions. Return statements must be
511 -- replaced by gotos which jump to the end of the routine and restore the
514 procedure Analyze_Contract_Cases_In_Decl_Part
516 Freeze_Id
: Entity_Id
:= Empty
)
518 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
519 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
521 Others_Seen
: Boolean := False;
522 -- This flag is set when an "others" choice is encountered. It is used
523 -- to detect multiple illegal occurrences of "others".
525 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
526 -- Verify the legality of a single contract case
528 ---------------------------
529 -- Analyze_Contract_Case --
530 ---------------------------
532 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
533 Case_Guard
: Node_Id
;
536 Extra_Guard
: Node_Id
;
539 if Nkind
(CCase
) = N_Component_Association
then
540 Case_Guard
:= First
(Choices
(CCase
));
541 Conseq
:= Expression
(CCase
);
543 -- Each contract case must have exactly one case guard
545 Extra_Guard
:= Next
(Case_Guard
);
547 if Present
(Extra_Guard
) then
549 ("contract case must have exactly one case guard",
553 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
555 if Nkind
(Case_Guard
) = N_Others_Choice
then
558 ("only one OTHERS choice allowed in contract cases",
564 elsif Others_Seen
then
566 ("OTHERS must be the last choice in contract cases", N
);
569 -- Preanalyze the case guard and consequence
571 if Nkind
(Case_Guard
) /= N_Others_Choice
then
572 Errors
:= Serious_Errors_Detected
;
573 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
575 -- Emit a clarification message when the case guard contains
576 -- at least one undefined reference, possibly due to contract
579 if Errors
/= Serious_Errors_Detected
580 and then Present
(Freeze_Id
)
581 and then Has_Undefined_Reference
(Case_Guard
)
583 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
587 Errors
:= Serious_Errors_Detected
;
588 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
590 -- Emit a clarification message when the consequence contains
591 -- at least one undefined reference, possibly due to contract
594 if Errors
/= Serious_Errors_Detected
595 and then Present
(Freeze_Id
)
596 and then Has_Undefined_Reference
(Conseq
)
598 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
601 -- The contract case is malformed
604 Error_Msg_N
("wrong syntax in contract case", CCase
);
606 end Analyze_Contract_Case
;
610 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
612 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
613 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
614 -- Save the Ghost-related attributes to restore on exit
617 Restore_Scope
: Boolean := False;
619 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
622 -- Do not analyze the pragma multiple times
624 if Is_Analyzed_Pragma
(N
) then
628 -- Set the Ghost mode in effect from the pragma. Due to the delayed
629 -- analysis of the pragma, the Ghost mode at point of declaration and
630 -- point of analysis may not necessarily be the same. Use the mode in
631 -- effect at the point of declaration.
635 -- Single and multiple contract cases must appear in aggregate form. If
636 -- this is not the case, then either the parser or the analysis of the
637 -- pragma failed to produce an aggregate, e.g. when the contract is
638 -- "null" or a "(null record)".
641 (if Nkind
(CCases
) = N_Aggregate
642 then Null_Record_Present
(CCases
)
643 xor (Present
(Component_Associations
(CCases
))
645 Present
(Expressions
(CCases
)))
646 else Nkind
(CCases
) = N_Null
);
648 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
650 if Nkind
(CCases
) = N_Aggregate
651 and then Present
(Component_Associations
(CCases
))
652 and then No
(Expressions
(CCases
))
655 -- Check that the expression is a proper aggregate (no parentheses)
657 if Paren_Count
(CCases
) /= 0 then
658 Error_Msg_F
-- CODEFIX
659 ("redundant parentheses", CCases
);
662 -- Ensure that the formal parameters are visible when analyzing all
663 -- clauses. This falls out of the general rule of aspects pertaining
664 -- to subprogram declarations.
666 if not In_Open_Scopes
(Spec_Id
) then
667 Restore_Scope
:= True;
668 Push_Scope
(Spec_Id
);
670 if Is_Generic_Subprogram
(Spec_Id
) then
671 Install_Generic_Formals
(Spec_Id
);
673 Install_Formals
(Spec_Id
);
677 CCase
:= First
(Component_Associations
(CCases
));
678 while Present
(CCase
) loop
679 Analyze_Contract_Case
(CCase
);
683 if Restore_Scope
then
687 -- Currently it is not possible to inline pre/postconditions on a
688 -- subprogram subject to pragma Inline_Always.
690 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
692 -- Otherwise the pragma is illegal
695 Error_Msg_N
("wrong syntax for contract cases", N
);
698 Set_Is_Analyzed_Pragma
(N
);
700 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
701 end Analyze_Contract_Cases_In_Decl_Part
;
703 ----------------------------------
704 -- Analyze_Depends_In_Decl_Part --
705 ----------------------------------
707 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
708 Loc
: constant Source_Ptr
:= Sloc
(N
);
709 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
710 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
712 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
713 -- A list containing the entities of all the inputs processed so far.
714 -- The list is populated with unique entities because the same input
715 -- may appear in multiple input lists.
717 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
718 -- A list containing the entities of all the outputs processed so far.
719 -- The list is populated with unique entities because output items are
720 -- unique in a dependence relation.
722 Constits_Seen
: Elist_Id
:= No_Elist
;
723 -- A list containing the entities of all constituents processed so far.
724 -- It aids in detecting illegal usage of a state and a corresponding
725 -- constituent in pragma [Refinde_]Depends.
727 Global_Seen
: Boolean := False;
728 -- A flag set when pragma Global has been processed
730 Null_Output_Seen
: Boolean := False;
731 -- A flag used to track the legality of a null output
733 Result_Seen
: Boolean := False;
734 -- A flag set when Spec_Id'Result is processed
736 States_Seen
: Elist_Id
:= No_Elist
;
737 -- A list containing the entities of all states processed so far. It
738 -- helps in detecting illegal usage of a state and a corresponding
739 -- constituent in pragma [Refined_]Depends.
741 Subp_Inputs
: Elist_Id
:= No_Elist
;
742 Subp_Outputs
: Elist_Id
:= No_Elist
;
743 -- Two lists containing the full set of inputs and output of the related
744 -- subprograms. Note that these lists contain both nodes and entities.
746 Task_Input_Seen
: Boolean := False;
747 Task_Output_Seen
: Boolean := False;
748 -- Flags used to track the implicit dependence of a task unit on itself
750 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
751 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
752 -- to the name buffer. The individual kinds are as follows:
753 -- E_Abstract_State - "state"
754 -- E_Constant - "constant"
755 -- E_Generic_In_Out_Parameter - "generic parameter"
756 -- E_Generic_In_Parameter - "generic parameter"
757 -- E_In_Parameter - "parameter"
758 -- E_In_Out_Parameter - "parameter"
759 -- E_Loop_Parameter - "loop parameter"
760 -- E_Out_Parameter - "parameter"
761 -- E_Protected_Type - "current instance of protected type"
762 -- E_Task_Type - "current instance of task type"
763 -- E_Variable - "global"
765 procedure Analyze_Dependency_Clause
768 -- Verify the legality of a single dependency clause. Flag Is_Last
769 -- denotes whether Clause is the last clause in the relation.
771 procedure Check_Function_Return
;
772 -- Verify that Funtion'Result appears as one of the outputs
773 -- (SPARK RM 6.1.5(10)).
780 -- Ensure that an item fulfills its designated input and/or output role
781 -- as specified by pragma Global (if any) or the enclosing context. If
782 -- this is not the case, emit an error. Item and Item_Id denote the
783 -- attributes of an item. Flag Is_Input should be set when item comes
784 -- from an input list. Flag Self_Ref should be set when the item is an
785 -- output and the dependency clause has operator "+".
787 procedure Check_Usage
788 (Subp_Items
: Elist_Id
;
789 Used_Items
: Elist_Id
;
791 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
792 -- error if this is not the case.
794 procedure Normalize_Clause
(Clause
: Node_Id
);
795 -- Remove a self-dependency "+" from the input list of a clause
797 -----------------------------
798 -- Add_Item_To_Name_Buffer --
799 -----------------------------
801 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
803 if Ekind
(Item_Id
) = E_Abstract_State
then
804 Add_Str_To_Name_Buffer
("state");
806 elsif Ekind
(Item_Id
) = E_Constant
then
807 Add_Str_To_Name_Buffer
("constant");
809 elsif Is_Formal_Object
(Item_Id
) then
810 Add_Str_To_Name_Buffer
("generic parameter");
812 elsif Is_Formal
(Item_Id
) then
813 Add_Str_To_Name_Buffer
("parameter");
815 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
816 Add_Str_To_Name_Buffer
("loop parameter");
818 elsif Ekind
(Item_Id
) = E_Protected_Type
819 or else Is_Single_Protected_Object
(Item_Id
)
821 Add_Str_To_Name_Buffer
("current instance of protected type");
823 elsif Ekind
(Item_Id
) = E_Task_Type
824 or else Is_Single_Task_Object
(Item_Id
)
826 Add_Str_To_Name_Buffer
("current instance of task type");
828 elsif Ekind
(Item_Id
) = E_Variable
then
829 Add_Str_To_Name_Buffer
("global");
831 -- The routine should not be called with non-SPARK items
836 end Add_Item_To_Name_Buffer
;
838 -------------------------------
839 -- Analyze_Dependency_Clause --
840 -------------------------------
842 procedure Analyze_Dependency_Clause
846 procedure Analyze_Input_List
(Inputs
: Node_Id
);
847 -- Verify the legality of a single input list
849 procedure Analyze_Input_Output
854 Seen
: in out Elist_Id
;
855 Null_Seen
: in out Boolean;
856 Non_Null_Seen
: in out Boolean);
857 -- Verify the legality of a single input or output item. Flag
858 -- Is_Input should be set whenever Item is an input, False when it
859 -- denotes an output. Flag Self_Ref should be set when the item is an
860 -- output and the dependency clause has a "+". Flag Top_Level should
861 -- be set whenever Item appears immediately within an input or output
862 -- list. Seen is a collection of all abstract states, objects and
863 -- formals processed so far. Flag Null_Seen denotes whether a null
864 -- input or output has been encountered. Flag Non_Null_Seen denotes
865 -- whether a non-null input or output has been encountered.
867 ------------------------
868 -- Analyze_Input_List --
869 ------------------------
871 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
872 Inputs_Seen
: Elist_Id
:= No_Elist
;
873 -- A list containing the entities of all inputs that appear in the
874 -- current input list.
876 Non_Null_Input_Seen
: Boolean := False;
877 Null_Input_Seen
: Boolean := False;
878 -- Flags used to check the legality of an input list
883 -- Multiple inputs appear as an aggregate
885 if Nkind
(Inputs
) = N_Aggregate
then
886 if Present
(Component_Associations
(Inputs
)) then
888 ("nested dependency relations not allowed", Inputs
);
890 elsif Present
(Expressions
(Inputs
)) then
891 Input
:= First
(Expressions
(Inputs
));
892 while Present
(Input
) loop
899 Null_Seen
=> Null_Input_Seen
,
900 Non_Null_Seen
=> Non_Null_Input_Seen
);
905 -- Syntax error, always report
908 Error_Msg_N
("malformed input dependency list", Inputs
);
911 -- Process a solitary input
920 Null_Seen
=> Null_Input_Seen
,
921 Non_Null_Seen
=> Non_Null_Input_Seen
);
924 -- Detect an illegal dependency clause of the form
928 if Null_Output_Seen
and then Null_Input_Seen
then
930 ("null dependency clause cannot have a null input list",
933 end Analyze_Input_List
;
935 --------------------------
936 -- Analyze_Input_Output --
937 --------------------------
939 procedure Analyze_Input_Output
944 Seen
: in out Elist_Id
;
945 Null_Seen
: in out Boolean;
946 Non_Null_Seen
: in out Boolean)
948 procedure Current_Task_Instance_Seen
;
949 -- Set the appropriate global flag when the current instance of a
950 -- task unit is encountered.
952 --------------------------------
953 -- Current_Task_Instance_Seen --
954 --------------------------------
956 procedure Current_Task_Instance_Seen
is
959 Task_Input_Seen
:= True;
961 Task_Output_Seen
:= True;
963 end Current_Task_Instance_Seen
;
967 Is_Output
: constant Boolean := not Is_Input
;
971 -- Start of processing for Analyze_Input_Output
974 -- Multiple input or output items appear as an aggregate
976 if Nkind
(Item
) = N_Aggregate
then
977 if not Top_Level
then
978 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
980 elsif Present
(Component_Associations
(Item
)) then
982 ("nested dependency relations not allowed", Item
);
984 -- Recursively analyze the grouped items
986 elsif Present
(Expressions
(Item
)) then
987 Grouped
:= First
(Expressions
(Item
));
988 while Present
(Grouped
) loop
991 Is_Input
=> Is_Input
,
992 Self_Ref
=> Self_Ref
,
995 Null_Seen
=> Null_Seen
,
996 Non_Null_Seen
=> Non_Null_Seen
);
1001 -- Syntax error, always report
1004 Error_Msg_N
("malformed dependency list", Item
);
1007 -- Process attribute 'Result in the context of a dependency clause
1009 elsif Is_Attribute_Result
(Item
) then
1010 Non_Null_Seen
:= True;
1014 -- Attribute 'Result is allowed to appear on the output side of
1015 -- a dependency clause (SPARK RM 6.1.5(6)).
1018 SPARK_Msg_N
("function result cannot act as input", Item
);
1020 elsif Null_Seen
then
1022 ("cannot mix null and non-null dependency items", Item
);
1025 Result_Seen
:= True;
1028 -- Detect multiple uses of null in a single dependency list or
1029 -- throughout the whole relation. Verify the placement of a null
1030 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
1032 elsif Nkind
(Item
) = N_Null
then
1035 ("multiple null dependency relations not allowed", Item
);
1037 elsif Non_Null_Seen
then
1039 ("cannot mix null and non-null dependency items", Item
);
1047 ("null output list must be the last clause in a "
1048 & "dependency relation", Item
);
1050 -- Catch a useless dependence of the form:
1055 ("useless dependence, null depends on itself", Item
);
1063 Non_Null_Seen
:= True;
1066 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
1070 Resolve_State
(Item
);
1072 -- Find the entity of the item. If this is a renaming, climb
1073 -- the renaming chain to reach the root object. Renamings of
1074 -- non-entire objects do not yield an entity (Empty).
1076 Item_Id
:= Entity_Of
(Item
);
1078 if Present
(Item_Id
) then
1082 if Ekind
(Item_Id
) in E_Constant | E_Loop_Parameter
1085 -- Current instances of concurrent types
1087 Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
1090 -- Formal parameters
1092 Ekind
(Item_Id
) in E_Generic_In_Out_Parameter
1093 | E_Generic_In_Parameter
1095 | E_In_Out_Parameter
1099 -- States, variables
1101 Ekind
(Item_Id
) in E_Abstract_State | E_Variable
1103 -- A [generic] function is not allowed to have Output
1104 -- items in its dependency relations. Note that "null"
1105 -- and attribute 'Result are still valid items.
1107 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1108 and then not Is_Function_With_Side_Effects
(Spec_Id
)
1109 and then not Is_Input
1112 GEC_Output_In_Function_Global_Or_Depends
;
1114 ("output item is not applicable to function '[[]']",
1118 -- The item denotes a concurrent type. Note that single
1119 -- protected/task types are not considered here because
1120 -- they behave as objects in the context of pragma
1121 -- [Refined_]Depends.
1123 if Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
1125 -- This use is legal as long as the concurrent type is
1126 -- the current instance of an enclosing type.
1128 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
1130 -- The dependence of a task unit on itself is
1131 -- implicit and may or may not be explicitly
1132 -- specified (SPARK RM 6.1.4).
1134 if Ekind
(Item_Id
) = E_Task_Type
then
1135 Current_Task_Instance_Seen
;
1138 -- Otherwise this is not the current instance
1142 ("invalid use of subtype mark in dependency "
1143 & "relation", Item
);
1146 -- The dependency of a task unit on itself is implicit
1147 -- and may or may not be explicitly specified
1148 -- (SPARK RM 6.1.4).
1150 elsif Is_Single_Task_Object
(Item_Id
)
1151 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
1153 Current_Task_Instance_Seen
;
1156 -- Ensure that the item fulfills its role as input and/or
1157 -- output as specified by pragma Global or the enclosing
1160 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1162 -- Detect multiple uses of the same state, variable or
1163 -- formal parameter. If this is not the case, add the
1164 -- item to the list of processed relations.
1166 if Contains
(Seen
, Item_Id
) then
1168 ("duplicate use of item &", Item
, Item_Id
);
1170 Append_New_Elmt
(Item_Id
, Seen
);
1173 -- Detect illegal use of an input related to a null
1174 -- output. Such input items cannot appear in other
1175 -- input lists (SPARK RM 6.1.5(13)).
1178 and then Null_Output_Seen
1179 and then Contains
(All_Inputs_Seen
, Item_Id
)
1182 ("input of a null output list cannot appear in "
1183 & "multiple input lists", Item
);
1186 -- Add an input or a self-referential output to the list
1187 -- of all processed inputs.
1189 if Is_Input
or else Self_Ref
then
1190 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1193 -- State related checks (SPARK RM 6.1.5(3))
1195 if Ekind
(Item_Id
) = E_Abstract_State
then
1197 -- Package and subprogram bodies are instantiated
1198 -- individually in a separate compiler pass. Due to
1199 -- this mode of instantiation, the refinement of a
1200 -- state may no longer be visible when a subprogram
1201 -- body contract is instantiated. Since the generic
1202 -- template is legal, do not perform this check in
1203 -- the instance to circumvent this oddity.
1208 -- An abstract state with visible refinement cannot
1209 -- appear in pragma [Refined_]Depends as its place
1210 -- must be taken by some of its constituents
1211 -- (SPARK RM 6.1.4(7)).
1213 elsif Has_Visible_Refinement
(Item_Id
) then
1215 ("cannot mention state & in dependence relation",
1217 SPARK_Msg_N
("\use its constituents instead", Item
);
1220 -- If the reference to the abstract state appears in
1221 -- an enclosing package body that will eventually
1222 -- refine the state, record the reference for future
1226 Record_Possible_Body_Reference
1227 (State_Id
=> Item_Id
,
1231 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
1232 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
1235 ("overlaying object & cannot appear in Depends",
1238 ("\use the overlaid object & instead",
1239 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
1243 -- When the item renames an entire object, replace the
1244 -- item with a reference to the object.
1246 if Entity
(Item
) /= Item_Id
then
1248 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1252 -- Add the entity of the current item to the list of
1255 if Ekind
(Item_Id
) = E_Abstract_State
then
1256 Append_New_Elmt
(Item_Id
, States_Seen
);
1258 -- The variable may eventually become a constituent of a
1259 -- single protected/task type. Record the reference now
1260 -- and verify its legality when analyzing the contract of
1261 -- the variable (SPARK RM 9.3).
1263 elsif Ekind
(Item_Id
) = E_Variable
then
1264 Record_Possible_Part_Of_Reference
1269 if Ekind
(Item_Id
) in E_Abstract_State
1272 and then Present
(Encapsulating_State
(Item_Id
))
1274 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1277 -- All other input/output items are illegal
1278 -- (SPARK RM 6.1.5(1)).
1282 ("item must denote parameter, variable, state or "
1283 & "current instance of concurrent type", Item
);
1286 -- All other input/output items are illegal
1287 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1291 ("item must denote parameter, variable, state or current "
1292 & "instance of concurrent type", Item
);
1295 end Analyze_Input_Output
;
1303 Non_Null_Output_Seen
: Boolean := False;
1304 -- Flag used to check the legality of an output list
1306 -- Start of processing for Analyze_Dependency_Clause
1309 Inputs
:= Expression
(Clause
);
1312 -- An input list with a self-dependency appears as operator "+" where
1313 -- the actuals inputs are the right operand.
1315 if Nkind
(Inputs
) = N_Op_Plus
then
1316 Inputs
:= Right_Opnd
(Inputs
);
1320 -- Process the output_list of a dependency_clause
1322 Output
:= First
(Choices
(Clause
));
1323 while Present
(Output
) loop
1324 Analyze_Input_Output
1327 Self_Ref
=> Self_Ref
,
1329 Seen
=> All_Outputs_Seen
,
1330 Null_Seen
=> Null_Output_Seen
,
1331 Non_Null_Seen
=> Non_Null_Output_Seen
);
1336 -- Process the input_list of a dependency_clause
1338 Analyze_Input_List
(Inputs
);
1339 end Analyze_Dependency_Clause
;
1341 ---------------------------
1342 -- Check_Function_Return --
1343 ---------------------------
1345 procedure Check_Function_Return
is
1347 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1348 and then not Result_Seen
1351 ("result of & must appear in exactly one output list",
1354 end Check_Function_Return
;
1360 procedure Check_Role
1362 Item_Id
: Entity_Id
;
1367 (Item_Is_Input
: out Boolean;
1368 Item_Is_Output
: out Boolean);
1369 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1370 -- Item_Is_Output are set depending on the role.
1372 procedure Role_Error
1373 (Item_Is_Input
: Boolean;
1374 Item_Is_Output
: Boolean);
1375 -- Emit an error message concerning the incorrect use of Item in
1376 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1377 -- denote whether the item is an input and/or an output.
1384 (Item_Is_Input
: out Boolean;
1385 Item_Is_Output
: out Boolean)
1387 -- A constant or an IN parameter of a procedure or a protected
1388 -- entry, if it is of an access-to-variable type, should be
1389 -- handled like a variable, as the underlying memory pointed-to
1390 -- can be modified. Use Adjusted_Kind to do this adjustment.
1392 Adjusted_Kind
: Entity_Kind
:= Ekind
(Item_Id
);
1395 if (Ekind
(Item_Id
) in E_Constant | E_Generic_In_Parameter
1397 (Ekind
(Item_Id
) = E_In_Parameter
1398 and then Ekind
(Scope
(Item_Id
))
1399 not in E_Function | E_Generic_Function
))
1400 and then Is_Access_Variable
(Etype
(Item_Id
))
1401 and then Ekind
(Spec_Id
) not in E_Function
1402 | E_Generic_Function
1404 Adjusted_Kind
:= E_Variable
;
1407 case Adjusted_Kind
is
1411 when E_Abstract_State
=>
1413 -- When pragma Global is present it determines the mode of
1414 -- the abstract state.
1417 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1418 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1420 -- Otherwise the state has a default IN OUT mode, because it
1421 -- behaves as a variable.
1424 Item_Is_Input
:= True;
1425 Item_Is_Output
:= True;
1428 -- Constants and IN parameters
1431 | E_Generic_In_Parameter
1435 -- When pragma Global is present it determines the mode
1436 -- of constant objects as inputs (and such objects cannot
1437 -- appear as outputs in the Global contract).
1440 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1442 Item_Is_Input
:= True;
1445 Item_Is_Output
:= False;
1447 -- Variables and IN OUT parameters, as well as constants and
1448 -- IN parameters of access type which are handled like
1451 when E_Generic_In_Out_Parameter
1452 | E_In_Out_Parameter
1456 -- An OUT parameter of the related subprogram; it cannot
1457 -- appear in Global.
1459 if Adjusted_Kind
= E_Out_Parameter
1460 and then Scope
(Item_Id
) = Spec_Id
1463 -- The parameter has mode IN if its type is unconstrained
1464 -- or tagged because array bounds, discriminants or tags
1468 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1470 Item_Is_Output
:= True;
1472 -- A parameter of an enclosing subprogram; it can appear
1473 -- in Global and behaves as a read-write variable.
1476 -- When pragma Global is present it determines the mode
1481 -- A variable has mode IN when its type is
1482 -- unconstrained or tagged because array bounds,
1483 -- discriminants, or tags can be read.
1486 Appears_In
(Subp_Inputs
, Item_Id
)
1487 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1489 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1491 -- Otherwise the variable has a default IN OUT mode
1494 Item_Is_Input
:= True;
1495 Item_Is_Output
:= True;
1501 when E_Protected_Type
=>
1504 -- A variable has mode IN when its type is unconstrained
1505 -- or tagged because array bounds, discriminants or tags
1509 Appears_In
(Subp_Inputs
, Item_Id
)
1510 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1512 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1515 -- A protected type acts as a formal parameter of mode IN
1516 -- when it applies to a protected function.
1518 if Ekind
(Spec_Id
) = E_Function
then
1519 Item_Is_Input
:= True;
1520 Item_Is_Output
:= False;
1522 -- Otherwise the protected type acts as a formal of mode
1526 Item_Is_Input
:= True;
1527 Item_Is_Output
:= True;
1535 -- When pragma Global is present it determines the mode of
1540 Appears_In
(Subp_Inputs
, Item_Id
)
1541 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1543 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1545 -- Otherwise task types act as IN OUT parameters
1548 Item_Is_Input
:= True;
1549 Item_Is_Output
:= True;
1553 raise Program_Error
;
1561 procedure Role_Error
1562 (Item_Is_Input
: Boolean;
1563 Item_Is_Output
: Boolean)
1568 -- When the item is not part of the input and the output set of
1569 -- the related subprogram, then it appears as extra in pragma
1570 -- [Refined_]Depends.
1572 if not Item_Is_Input
and then not Item_Is_Output
then
1573 Add_Item_To_Name_Buffer
(Item_Id
);
1574 Add_Str_To_Name_Buffer
1575 (" & cannot appear in dependence relation");
1577 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1579 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1581 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1582 & "set of subprogram %"), Item
, Item_Id
);
1584 -- The mode of the item and its role in pragma [Refined_]Depends
1585 -- are in conflict. Construct a detailed message explaining the
1586 -- illegality (SPARK RM 6.1.5(5-6)).
1589 if Item_Is_Input
then
1590 Add_Str_To_Name_Buffer
("read-only");
1592 Add_Str_To_Name_Buffer
("write-only");
1595 Add_Char_To_Name_Buffer
(' ');
1596 Add_Item_To_Name_Buffer
(Item_Id
);
1597 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1599 if Item_Is_Input
then
1600 Add_Str_To_Name_Buffer
("output");
1602 Add_Str_To_Name_Buffer
("input");
1605 Add_Str_To_Name_Buffer
(" in dependence relation");
1607 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1613 Item_Is_Input
: Boolean;
1614 Item_Is_Output
: Boolean;
1616 -- Start of processing for Check_Role
1619 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1624 if not Item_Is_Input
then
1625 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1628 -- Self-referential item
1631 if not Item_Is_Input
or else not Item_Is_Output
then
1632 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1637 elsif not Item_Is_Output
then
1638 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1646 procedure Check_Usage
1647 (Subp_Items
: Elist_Id
;
1648 Used_Items
: Elist_Id
;
1651 procedure Usage_Error
(Item_Id
: Entity_Id
);
1652 -- Emit an error concerning the illegal usage of an item
1658 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1664 -- Unconstrained and tagged items are not part of the explicit
1665 -- input set of the related subprogram, they do not have to be
1666 -- present in a dependence relation and should not be flagged
1667 -- (SPARK RM 6.1.5(5)).
1669 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1672 Add_Item_To_Name_Buffer
(Item_Id
);
1673 Add_Str_To_Name_Buffer
1674 (" & is missing from input dependence list");
1676 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1678 ("\add `null ='> &` dependency to ignore this input",
1682 -- Output case (SPARK RM 6.1.5(10))
1687 Add_Item_To_Name_Buffer
(Item_Id
);
1688 Add_Str_To_Name_Buffer
1689 (" & is missing from output dependence list");
1691 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1699 Item_Id
: Entity_Id
;
1701 -- Start of processing for Check_Usage
1704 if No
(Subp_Items
) then
1708 -- Each input or output of the subprogram must appear in a dependency
1711 Elmt
:= First_Elmt
(Subp_Items
);
1712 while Present
(Elmt
) loop
1713 Item
:= Node
(Elmt
);
1715 if Nkind
(Item
) = N_Defining_Identifier
then
1718 Item_Id
:= Entity_Of
(Item
);
1721 -- The item does not appear in a dependency
1723 if Present
(Item_Id
)
1724 and then not Contains
(Used_Items
, Item_Id
)
1726 if Is_Formal
(Item_Id
) then
1727 Usage_Error
(Item_Id
);
1729 -- The current instance of a protected type behaves as a formal
1730 -- parameter (SPARK RM 6.1.4).
1732 elsif Ekind
(Item_Id
) = E_Protected_Type
1733 or else Is_Single_Protected_Object
(Item_Id
)
1735 Usage_Error
(Item_Id
);
1737 -- The current instance of a task type behaves as a formal
1738 -- parameter (SPARK RM 6.1.4).
1740 elsif Ekind
(Item_Id
) = E_Task_Type
1741 or else Is_Single_Task_Object
(Item_Id
)
1743 -- The dependence of a task unit on itself is implicit and
1744 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1745 -- Emit an error if only one input/output is present.
1747 if Task_Input_Seen
/= Task_Output_Seen
then
1748 Usage_Error
(Item_Id
);
1751 -- States and global objects are not used properly only when
1752 -- the subprogram is subject to pragma Global.
1755 and then Ekind
(Item_Id
) in E_Abstract_State
1763 Usage_Error
(Item_Id
);
1771 ----------------------
1772 -- Normalize_Clause --
1773 ----------------------
1775 procedure Normalize_Clause
(Clause
: Node_Id
) is
1776 procedure Create_Or_Modify_Clause
1782 Multiple
: Boolean);
1783 -- Create a brand new clause to represent the self-reference or
1784 -- modify the input and/or output lists of an existing clause. Output
1785 -- denotes a self-referencial output. Outputs is the output list of a
1786 -- clause. Inputs is the input list of a clause. After denotes the
1787 -- clause after which the new clause is to be inserted. Flag In_Place
1788 -- should be set when normalizing the last output of an output list.
1789 -- Flag Multiple should be set when Output comes from a list with
1792 -----------------------------
1793 -- Create_Or_Modify_Clause --
1794 -----------------------------
1796 procedure Create_Or_Modify_Clause
1804 procedure Propagate_Output
1807 -- Handle the various cases of output propagation to the input
1808 -- list. Output denotes a self-referencial output item. Inputs
1809 -- is the input list of a clause.
1811 ----------------------
1812 -- Propagate_Output --
1813 ----------------------
1815 procedure Propagate_Output
1819 function In_Input_List
1821 Inputs
: List_Id
) return Boolean;
1822 -- Determine whether a particulat item appears in the input
1823 -- list of a clause.
1829 function In_Input_List
1831 Inputs
: List_Id
) return Boolean
1836 Elmt
:= First
(Inputs
);
1837 while Present
(Elmt
) loop
1838 if Entity_Of
(Elmt
) = Item
then
1850 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1853 -- Start of processing for Propagate_Output
1856 -- The clause is of the form:
1858 -- (Output =>+ null)
1860 -- Remove null input and replace it with a copy of the output:
1862 -- (Output => Output)
1864 if Nkind
(Inputs
) = N_Null
then
1865 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1867 -- The clause is of the form:
1869 -- (Output =>+ (Input1, ..., InputN))
1871 -- Determine whether the output is not already mentioned in the
1872 -- input list and if not, add it to the list of inputs:
1874 -- (Output => (Output, Input1, ..., InputN))
1876 elsif Nkind
(Inputs
) = N_Aggregate
then
1877 Grouped
:= Expressions
(Inputs
);
1879 if not In_Input_List
1883 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1886 -- The clause is of the form:
1888 -- (Output =>+ Input)
1890 -- If the input does not mention the output, group the two
1893 -- (Output => (Output, Input))
1895 elsif Entity_Of
(Inputs
) /= Output_Id
then
1897 Make_Aggregate
(Loc
,
1898 Expressions
=> New_List
(
1899 New_Copy_Tree
(Output
),
1900 New_Copy_Tree
(Inputs
))));
1902 end Propagate_Output
;
1906 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1907 New_Clause
: Node_Id
;
1909 -- Start of processing for Create_Or_Modify_Clause
1912 -- A null output depending on itself does not require any
1915 if Nkind
(Output
) = N_Null
then
1918 -- A function result cannot depend on itself because it cannot
1919 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1921 elsif Is_Attribute_Result
(Output
) then
1922 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1926 -- When performing the transformation in place, simply add the
1927 -- output to the list of inputs (if not already there). This
1928 -- case arises when dealing with the last output of an output
1929 -- list. Perform the normalization in place to avoid generating
1930 -- a malformed tree.
1933 Propagate_Output
(Output
, Inputs
);
1935 -- A list with multiple outputs is slowly trimmed until only
1936 -- one element remains. When this happens, replace aggregate
1937 -- with the element itself.
1941 Rewrite
(Outputs
, Output
);
1947 -- Unchain the output from its output list as it will appear in
1948 -- a new clause. Note that we cannot simply rewrite the output
1949 -- as null because this will violate the semantics of pragma
1954 -- Generate a new clause of the form:
1955 -- (Output => Inputs)
1958 Make_Component_Association
(Loc
,
1959 Choices
=> New_List
(Output
),
1960 Expression
=> New_Copy_Tree
(Inputs
));
1962 -- The new clause contains replicated content that has already
1963 -- been analyzed. There is not need to reanalyze or renormalize
1966 Set_Analyzed
(New_Clause
);
1969 (Output
=> First
(Choices
(New_Clause
)),
1970 Inputs
=> Expression
(New_Clause
));
1972 Insert_After
(After
, New_Clause
);
1974 end Create_Or_Modify_Clause
;
1978 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1980 Last_Output
: Node_Id
;
1981 Next_Output
: Node_Id
;
1984 -- Start of processing for Normalize_Clause
1987 -- A self-dependency appears as operator "+". Remove the "+" from the
1988 -- tree by moving the real inputs to their proper place.
1990 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1991 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1992 Inputs
:= Expression
(Clause
);
1994 -- Multiple outputs appear as an aggregate
1996 if Nkind
(Outputs
) = N_Aggregate
then
1997 Last_Output
:= Last
(Expressions
(Outputs
));
1999 Output
:= First
(Expressions
(Outputs
));
2000 while Present
(Output
) loop
2002 -- Normalization may remove an output from its list,
2003 -- preserve the subsequent output now.
2005 Next_Output
:= Next
(Output
);
2007 Create_Or_Modify_Clause
2012 In_Place
=> Output
= Last_Output
,
2015 Output
:= Next_Output
;
2021 Create_Or_Modify_Clause
2030 end Normalize_Clause
;
2034 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2035 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2039 Last_Clause
: Node_Id
;
2040 Restore_Scope
: Boolean := False;
2042 -- Start of processing for Analyze_Depends_In_Decl_Part
2045 -- Do not analyze the pragma multiple times
2047 if Is_Analyzed_Pragma
(N
) then
2051 -- Empty dependency list
2053 if Nkind
(Deps
) = N_Null
then
2055 -- Gather all states, objects and formal parameters that the
2056 -- subprogram may depend on. These items are obtained from the
2057 -- parameter profile or pragma [Refined_]Global (if available).
2059 Collect_Subprogram_Inputs_Outputs
2060 (Subp_Id
=> Subp_Id
,
2061 Subp_Inputs
=> Subp_Inputs
,
2062 Subp_Outputs
=> Subp_Outputs
,
2063 Global_Seen
=> Global_Seen
);
2065 -- Verify that every input or output of the subprogram appear in a
2068 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
2069 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
2070 Check_Function_Return
;
2072 -- Dependency clauses appear as component associations of an aggregate
2074 elsif Nkind
(Deps
) = N_Aggregate
then
2076 -- Do not attempt to perform analysis of a syntactically illegal
2077 -- clause as this will lead to misleading errors.
2079 if Has_Extra_Parentheses
(Deps
) then
2083 if Present
(Component_Associations
(Deps
)) then
2084 Last_Clause
:= Last
(Component_Associations
(Deps
));
2086 -- Gather all states, objects and formal parameters that the
2087 -- subprogram may depend on. These items are obtained from the
2088 -- parameter profile or pragma [Refined_]Global (if available).
2090 Collect_Subprogram_Inputs_Outputs
2091 (Subp_Id
=> Subp_Id
,
2092 Subp_Inputs
=> Subp_Inputs
,
2093 Subp_Outputs
=> Subp_Outputs
,
2094 Global_Seen
=> Global_Seen
);
2096 -- When pragma [Refined_]Depends appears on a single concurrent
2097 -- type, it is relocated to the anonymous object.
2099 if Is_Single_Concurrent_Object
(Spec_Id
) then
2102 -- Ensure that the formal parameters are visible when analyzing
2103 -- all clauses. This falls out of the general rule of aspects
2104 -- pertaining to subprogram declarations.
2106 elsif not In_Open_Scopes
(Spec_Id
) then
2107 Restore_Scope
:= True;
2108 Push_Scope
(Spec_Id
);
2110 if Ekind
(Spec_Id
) = E_Task_Type
then
2112 -- Task discriminants cannot appear in the [Refined_]Depends
2113 -- contract, but must be present for the analysis so that we
2114 -- can reject them with an informative error message.
2116 if Has_Discriminants
(Spec_Id
) then
2117 Install_Discriminants
(Spec_Id
);
2120 elsif Is_Generic_Subprogram
(Spec_Id
) then
2121 Install_Generic_Formals
(Spec_Id
);
2124 Install_Formals
(Spec_Id
);
2128 Clause
:= First
(Component_Associations
(Deps
));
2129 while Present
(Clause
) loop
2130 Errors
:= Serious_Errors_Detected
;
2132 -- The normalization mechanism may create extra clauses that
2133 -- contain replicated input and output names. There is no need
2134 -- to reanalyze them.
2136 if not Analyzed
(Clause
) then
2137 Set_Analyzed
(Clause
);
2139 Analyze_Dependency_Clause
2141 Is_Last
=> Clause
= Last_Clause
);
2144 -- Do not normalize a clause if errors were detected (count
2145 -- of Serious_Errors has increased) because the inputs and/or
2146 -- outputs may denote illegal items.
2148 if Serious_Errors_Detected
= Errors
then
2149 Normalize_Clause
(Clause
);
2155 if Restore_Scope
then
2159 -- Verify that every input or output of the subprogram appear in a
2162 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
2163 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
2164 Check_Function_Return
;
2166 -- The dependency list is malformed. This is a syntax error, always
2170 Error_Msg_N
("malformed dependency relation", Deps
);
2174 -- The top level dependency relation is malformed. This is a syntax
2175 -- error, always report.
2178 Error_Msg_N
("malformed dependency relation", Deps
);
2182 -- Ensure that a state and a corresponding constituent do not appear
2183 -- together in pragma [Refined_]Depends.
2185 Check_State_And_Constituent_Use
2186 (States
=> States_Seen
,
2187 Constits
=> Constits_Seen
,
2191 Set_Is_Analyzed_Pragma
(N
);
2192 end Analyze_Depends_In_Decl_Part
;
2194 --------------------------------------------
2195 -- Analyze_Exceptional_Cases_In_Decl_Part --
2196 --------------------------------------------
2198 -- WARNING: This routine manages Ghost regions. Return statements must be
2199 -- replaced by gotos which jump to the end of the routine and restore the
2202 procedure Analyze_Exceptional_Cases_In_Decl_Part
2204 Freeze_Id
: Entity_Id
:= Empty
)
2206 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2207 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2209 procedure Analyze_Exceptional_Contract
(Exceptional_Contract
: Node_Id
);
2210 -- Verify the legality of a single exceptional contract
2212 procedure Check_Duplication
(Id
: Node_Id
; Contracts
: List_Id
);
2213 -- Iterate through the identifiers in each contract to find duplicates
2215 ----------------------------------
2216 -- Analyze_Exceptional_Contract --
2217 ----------------------------------
2219 procedure Analyze_Exceptional_Contract
(Exceptional_Contract
: Node_Id
)
2221 Exception_Choice
: Node_Id
;
2222 Consequence
: Node_Id
;
2226 if Nkind
(Exceptional_Contract
) /= N_Component_Association
then
2228 ("wrong syntax in exceptional contract", Exceptional_Contract
);
2232 Exception_Choice
:= First
(Choices
(Exceptional_Contract
));
2233 Consequence
:= Expression
(Exceptional_Contract
);
2235 while Present
(Exception_Choice
) loop
2236 if Nkind
(Exception_Choice
) = N_Others_Choice
then
2237 if Present
(Next
(Exception_Choice
))
2238 or else Present
(Next
(Exceptional_Contract
))
2239 or else Present
(Prev
(Exception_Choice
))
2242 ("OTHERS must appear alone and last", Exception_Choice
);
2246 Analyze
(Exception_Choice
);
2248 if Is_Entity_Name
(Exception_Choice
)
2249 and then Ekind
(Entity
(Exception_Choice
)) = E_Exception
2251 if Present
(Renamed_Entity
(Entity
(Exception_Choice
)))
2252 and then Entity
(Exception_Choice
) = Standard_Numeric_Error
2255 (No_Obsolescent_Features
, Exception_Choice
);
2257 if Warn_On_Obsolescent_Feature
then
2259 ("Numeric_Error is an obsolescent feature " &
2263 ("\use Constraint_Error instead?j?",
2269 (Exception_Choice
, List_Containing
(Exceptional_Contract
));
2271 -- Check for exception declared within generic formal
2272 -- package (which is illegal, see RM 11.2(8)).
2275 Ent
: Entity_Id
:= Entity
(Exception_Choice
);
2279 if Present
(Renamed_Entity
(Ent
)) then
2280 Ent
:= Renamed_Entity
(Ent
);
2283 Scop
:= Scope
(Ent
);
2284 while Scop
/= Standard_Standard
2285 and then Ekind
(Scop
) = E_Package
2287 if Nkind
(Declaration_Node
(Scop
)) =
2288 N_Package_Specification
2290 Nkind
(Original_Node
(Parent
2291 (Declaration_Node
(Scop
)))) =
2292 N_Formal_Package_Declaration
2295 ("exception& is declared in generic formal "
2296 & "package", Exception_Choice
, Ent
);
2298 ("\and therefore cannot appear in contract "
2299 & "(RM 11.2(8))", Exception_Choice
);
2302 -- If the exception is declared in an inner instance,
2303 -- nothing else to check.
2305 elsif Is_Generic_Instance
(Scop
) then
2309 Scop
:= Scope
(Scop
);
2313 Error_Msg_N
("exception name expected", Exception_Choice
);
2317 Next
(Exception_Choice
);
2320 -- Now analyze the expressions of this contract
2322 Errors
:= Serious_Errors_Detected
;
2324 -- Preanalyze_Assert_Expression, but without enforcing any of the two
2325 -- acceptable types.
2327 Preanalyze_Assert_Expression
(Consequence
, Any_Boolean
);
2329 -- Emit a clarification message when the consequence contains at
2330 -- least one undefined reference, possibly due to contract freezing.
2332 if Errors
/= Serious_Errors_Detected
2333 and then Present
(Freeze_Id
)
2334 and then Has_Undefined_Reference
(Consequence
)
2336 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
2338 end Analyze_Exceptional_Contract
;
2340 -----------------------
2341 -- Check_Duplication --
2342 -----------------------
2344 procedure Check_Duplication
(Id
: Node_Id
; Contracts
: List_Id
) is
2347 Id_Entity
: Entity_Id
:= Entity
(Id
);
2350 if Present
(Renamed_Entity
(Id_Entity
)) then
2351 Id_Entity
:= Renamed_Entity
(Id_Entity
);
2354 Contract
:= First
(Contracts
);
2355 while Present
(Contract
) loop
2356 Id1
:= First
(Choices
(Contract
));
2357 while Present
(Id1
) loop
2359 -- Only check against the exception choices which precede
2360 -- Id in the contract, since the ones that follow Id have not
2361 -- been analyzed yet and will be checked in a subsequent call.
2366 -- Duplication both simple and via a renaming across different
2367 -- exceptional contracts is illegal.
2369 elsif Nkind
(Id1
) /= N_Others_Choice
2371 (Id_Entity
= Entity
(Id1
)
2372 or else Id_Entity
= Renamed_Entity
(Entity
(Id1
)))
2373 and then Contract
/= Parent
(Id
)
2375 Error_Msg_Sloc
:= Sloc
(Id1
);
2376 Error_Msg_NE
("exception choice duplicates &#", Id
, Id1
);
2384 end Check_Duplication
;
2388 Exceptional_Contracts
: constant Node_Id
:=
2389 Expression
(Get_Argument
(N
, Spec_Id
));
2391 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2392 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2393 -- Save the Ghost-related attributes to restore on exit
2395 Exceptional_Contract
: Node_Id
;
2396 Restore_Scope
: Boolean := False;
2398 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
2401 -- Do not analyze the pragma multiple times
2403 if Is_Analyzed_Pragma
(N
) then
2407 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2408 -- analysis of the pragma, the Ghost mode at point of declaration and
2409 -- point of analysis may not necessarily be the same. Use the mode in
2410 -- effect at the point of declaration.
2414 -- Single and multiple contracts must appear in aggregate form. If this
2415 -- is not the case, then either the parser of the analysis of the pragma
2416 -- failed to produce an aggregate, e.g. when the contract is "null" or a
2420 (if Nkind
(Exceptional_Contracts
) = N_Aggregate
2421 then Null_Record_Present
(Exceptional_Contracts
)
2422 xor (Present
(Component_Associations
(Exceptional_Contracts
))
2424 Present
(Expressions
(Exceptional_Contracts
)))
2425 else Nkind
(Exceptional_Contracts
) = N_Null
);
2427 -- Only clauses of the following form are allowed:
2429 -- exceptional_contract ::=
2430 -- [choice_parameter_specification:]
2431 -- exception_choice {'|' exception_choice} => consequence
2435 -- consequence ::= Boolean_expression
2437 if Nkind
(Exceptional_Contracts
) = N_Aggregate
2438 and then Present
(Component_Associations
(Exceptional_Contracts
))
2439 and then No
(Expressions
(Exceptional_Contracts
))
2442 -- Check that the expression is a proper aggregate (no parentheses)
2444 if Paren_Count
(Exceptional_Contracts
) /= 0 then
2445 Error_Msg_F
-- CODEFIX
2446 ("redundant parentheses", Exceptional_Contracts
);
2449 -- Ensure that the formal parameters are visible when analyzing all
2450 -- clauses. This falls out of the general rule of aspects pertaining
2451 -- to subprogram declarations.
2453 if not In_Open_Scopes
(Spec_Id
) then
2454 Restore_Scope
:= True;
2455 Push_Scope
(Spec_Id
);
2457 if Is_Generic_Subprogram
(Spec_Id
) then
2458 Install_Generic_Formals
(Spec_Id
);
2460 Install_Formals
(Spec_Id
);
2464 Exceptional_Contract
:=
2465 First
(Component_Associations
(Exceptional_Contracts
));
2466 while Present
(Exceptional_Contract
) loop
2467 Analyze_Exceptional_Contract
(Exceptional_Contract
);
2468 Next
(Exceptional_Contract
);
2471 if Restore_Scope
then
2475 -- Otherwise the pragma is illegal
2478 Error_Msg_N
("wrong syntax for exceptional cases", N
);
2481 Set_Is_Analyzed_Pragma
(N
);
2483 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2484 end Analyze_Exceptional_Cases_In_Decl_Part
;
2486 --------------------------------------------
2487 -- Analyze_External_Property_In_Decl_Part --
2488 --------------------------------------------
2490 procedure Analyze_External_Property_In_Decl_Part
2492 Expr_Val
: out Boolean)
2494 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pragma_Name
(N
));
2495 Arg1
: constant Node_Id
:=
2496 First
(Pragma_Argument_Associations
(N
));
2497 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2498 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2499 Obj_Typ
: Entity_Id
;
2503 if Is_Type
(Obj_Id
) then
2506 Obj_Typ
:= Etype
(Obj_Id
);
2509 -- Ensure that the Boolean expression (if present) is static. A missing
2510 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2514 if Present
(Arg1
) then
2515 Expr
:= Get_Pragma_Arg
(Arg1
);
2517 if Is_OK_Static_Expression
(Expr
) then
2518 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2522 -- The output parameter was set to the argument specified by the pragma.
2523 -- Do not analyze the pragma multiple times.
2525 if Is_Analyzed_Pragma
(N
) then
2529 Error_Msg_Name_1
:= Pragma_Name
(N
);
2531 -- An external property pragma must apply to an effectively volatile
2532 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2533 -- The check is performed at the end of the declarative region due to a
2534 -- possible out-of-order arrangement of pragmas:
2537 -- pragma Async_Readers (Obj);
2538 -- pragma Volatile (Obj);
2540 if Prag_Id
/= Pragma_No_Caching
2541 and then not Is_Effectively_Volatile
(Obj_Id
)
2543 if No_Caching_Enabled
(Obj_Id
) then
2544 if Expr_Val
then -- Confirming value of False is allowed
2546 ("illegal combination of external property % and property "
2547 & """No_Caching"" (SPARK RM 7.1.2(6))", N
);
2551 ("external property % must apply to a volatile type or object",
2555 -- Pragma No_Caching should only apply to volatile types or variables of
2556 -- a non-effectively volatile type (SPARK RM 7.1.2).
2558 elsif Prag_Id
= Pragma_No_Caching
then
2559 if Is_Effectively_Volatile
(Obj_Typ
) then
2560 SPARK_Msg_N
("property % must not apply to a type or object of "
2561 & "an effectively volatile type", N
);
2562 elsif not Is_Volatile
(Obj_Id
) then
2564 ("property % must apply to a volatile type or object", N
);
2568 Set_Is_Analyzed_Pragma
(N
);
2569 end Analyze_External_Property_In_Decl_Part
;
2571 ---------------------------------
2572 -- Analyze_Global_In_Decl_Part --
2573 ---------------------------------
2575 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2576 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2577 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2578 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2580 Constits_Seen
: Elist_Id
:= No_Elist
;
2581 -- A list containing the entities of all constituents processed so far.
2582 -- It aids in detecting illegal usage of a state and a corresponding
2583 -- constituent in pragma [Refinde_]Global.
2585 Seen
: Elist_Id
:= No_Elist
;
2586 -- A list containing the entities of all the items processed so far. It
2587 -- plays a role in detecting distinct entities.
2589 States_Seen
: Elist_Id
:= No_Elist
;
2590 -- A list containing the entities of all states processed so far. It
2591 -- helps in detecting illegal usage of a state and a corresponding
2592 -- constituent in pragma [Refined_]Global.
2594 In_Out_Seen
: Boolean := False;
2595 Input_Seen
: Boolean := False;
2596 Output_Seen
: Boolean := False;
2597 Proof_Seen
: Boolean := False;
2598 -- Flags used to verify the consistency of modes
2600 procedure Analyze_Global_List
2602 Global_Mode
: Name_Id
:= Name_Input
);
2603 -- Verify the legality of a single global list declaration. Global_Mode
2604 -- denotes the current mode in effect.
2606 -------------------------
2607 -- Analyze_Global_List --
2608 -------------------------
2610 procedure Analyze_Global_List
2612 Global_Mode
: Name_Id
:= Name_Input
)
2614 procedure Analyze_Global_Item
2616 Global_Mode
: Name_Id
);
2617 -- Verify the legality of a single global item declaration denoted by
2618 -- Item. Global_Mode denotes the current mode in effect.
2620 procedure Check_Duplicate_Mode
2622 Status
: in out Boolean);
2623 -- Flag Status denotes whether a particular mode has been seen while
2624 -- processing a global list. This routine verifies that Mode is not a
2625 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2627 procedure Check_Mode_Restriction_In_Enclosing_Context
2629 Item_Id
: Entity_Id
);
2630 -- Verify that an item of mode In_Out or Output does not appear as
2631 -- an input in the Global aspect of an enclosing subprogram or task
2632 -- unit. If this is the case, emit an error. Item and Item_Id are
2633 -- respectively the item and its entity.
2635 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2636 -- Mode denotes either In_Out or Output. Depending on the kind of the
2637 -- related subprogram, emit an error if those two modes apply to a
2638 -- function (SPARK RM 6.1.4(10)).
2640 -------------------------
2641 -- Analyze_Global_Item --
2642 -------------------------
2644 procedure Analyze_Global_Item
2646 Global_Mode
: Name_Id
)
2648 Item_Id
: Entity_Id
;
2651 -- Detect one of the following cases
2653 -- with Global => (null, Name)
2654 -- with Global => (Name_1, null, Name_2)
2655 -- with Global => (Name, null)
2657 if Nkind
(Item
) = N_Null
then
2658 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2663 Resolve_State
(Item
);
2665 -- Find the entity of the item. If this is a renaming, climb the
2666 -- renaming chain to reach the root object. Renamings of non-
2667 -- entire objects do not yield an entity (Empty).
2669 Item_Id
:= Entity_Of
(Item
);
2671 if Present
(Item_Id
) then
2673 -- A global item may denote a formal parameter of an enclosing
2674 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2675 -- provide a better error diagnostic.
2677 if Is_Formal
(Item_Id
) then
2678 if Scope
(Item_Id
) = Spec_Id
then
2680 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2681 & "parameter of subprogram &"), Item
, Spec_Id
);
2685 -- A global item may denote a concurrent type as long as it is
2686 -- the current instance of an enclosing protected or task type
2687 -- (SPARK RM 6.1.4).
2689 elsif Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
2690 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2692 -- Pragma [Refined_]Global associated with a protected
2693 -- subprogram cannot mention the current instance of a
2694 -- protected type because the instance behaves as a
2695 -- formal parameter.
2697 if Ekind
(Item_Id
) = E_Protected_Type
then
2698 if Scope
(Spec_Id
) = Item_Id
then
2699 Error_Msg_Name_1
:= Chars
(Item_Id
);
2701 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2702 & "cannot reference current instance of "
2703 & "protected type %"), Item
, Spec_Id
);
2707 -- Pragma [Refined_]Global associated with a task type
2708 -- cannot mention the current instance of a task type
2709 -- because the instance behaves as a formal parameter.
2711 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2712 if Spec_Id
= Item_Id
then
2713 Error_Msg_Name_1
:= Chars
(Item_Id
);
2715 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2716 & "cannot reference current instance of task "
2717 & "type %"), Item
, Spec_Id
);
2722 -- Otherwise the global item denotes a subtype mark that is
2723 -- not a current instance.
2727 ("invalid use of subtype mark in global list", Item
);
2731 -- A global item may denote the anonymous object created for a
2732 -- single protected/task type as long as the current instance
2733 -- is the same single type (SPARK RM 6.1.4).
2735 elsif Is_Single_Concurrent_Object
(Item_Id
)
2736 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2738 -- Pragma [Refined_]Global associated with a protected
2739 -- subprogram cannot mention the current instance of a
2740 -- protected type because the instance behaves as a formal
2743 if Is_Single_Protected_Object
(Item_Id
) then
2744 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2745 Error_Msg_Name_1
:= Chars
(Item_Id
);
2747 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2748 & "cannot reference current instance of protected "
2749 & "type %"), Item
, Spec_Id
);
2753 -- Pragma [Refined_]Global associated with a task type
2754 -- cannot mention the current instance of a task type
2755 -- because the instance behaves as a formal parameter.
2757 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2758 if Spec_Id
= Item_Id
then
2759 Error_Msg_Name_1
:= Chars
(Item_Id
);
2761 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2762 & "cannot reference current instance of task "
2763 & "type %"), Item
, Spec_Id
);
2768 -- A formal object may act as a global item inside a generic
2770 elsif Is_Formal_Object
(Item_Id
) then
2773 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
2774 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
2777 ("overlaying object & cannot appear in Global",
2780 ("\use the overlaid object & instead",
2781 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
2784 -- The only legal references are those to abstract states,
2785 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2787 elsif Ekind
(Item_Id
) not in E_Abstract_State
2793 ("global item must denote object, state or current "
2794 & "instance of concurrent type", Item
);
2796 if Is_Named_Number
(Item_Id
) then
2798 ("\named number & is not an object", Item
, Item_Id
);
2804 -- State related checks
2806 if Ekind
(Item_Id
) = E_Abstract_State
then
2808 -- Package and subprogram bodies are instantiated
2809 -- individually in a separate compiler pass. Due to this
2810 -- mode of instantiation, the refinement of a state may
2811 -- no longer be visible when a subprogram body contract
2812 -- is instantiated. Since the generic template is legal,
2813 -- do not perform this check in the instance to circumvent
2819 -- An abstract state with visible refinement cannot appear
2820 -- in pragma [Refined_]Global as its place must be taken by
2821 -- some of its constituents (SPARK RM 6.1.4(7)).
2823 elsif Has_Visible_Refinement
(Item_Id
) then
2825 ("cannot mention state & in global refinement",
2827 SPARK_Msg_N
("\use its constituents instead", Item
);
2830 -- If the reference to the abstract state appears in an
2831 -- enclosing package body that will eventually refine the
2832 -- state, record the reference for future checks.
2835 Record_Possible_Body_Reference
2836 (State_Id
=> Item_Id
,
2840 -- Constant related checks
2842 elsif Ekind
(Item_Id
) = E_Constant
then
2844 -- Constant is a read-only item, therefore it cannot act as
2847 if Global_Mode
in Name_In_Out | Name_Output
then
2849 -- Constant of an access-to-variable type is a read-write
2850 -- item in procedures, generic procedures, protected
2851 -- entries and tasks.
2853 if Is_Access_Variable
(Etype
(Item_Id
))
2854 and then (Ekind
(Spec_Id
) in E_Entry
2857 | E_Generic_Procedure
2859 or else Is_Single_Task_Object
(Spec_Id
))
2864 ("constant & cannot act as output", Item
, Item_Id
);
2869 -- Loop parameter related checks
2871 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2873 -- A loop parameter is a read-only item, therefore it cannot
2874 -- act as an output.
2876 if Global_Mode
in Name_In_Out | Name_Output
then
2878 ("loop parameter & cannot act as output",
2884 -- When the item renames an entire object, replace the item
2885 -- with a reference to the object.
2887 if Entity
(Item
) /= Item_Id
then
2888 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2892 -- Some form of illegal construct masquerading as a name
2893 -- (SPARK RM 6.1.4(4)).
2897 ("global item must denote object, state or current instance "
2898 & "of concurrent type", Item
);
2902 -- Verify that an output does not appear as an input in an
2903 -- enclosing subprogram.
2905 if Global_Mode
in Name_In_Out | Name_Output
then
2906 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2909 -- The same entity might be referenced through various way.
2910 -- Check the entity of the item rather than the item itself
2911 -- (SPARK RM 6.1.4(10)).
2913 if Contains
(Seen
, Item_Id
) then
2914 SPARK_Msg_N
("duplicate global item", Item
);
2916 -- Add the entity of the current item to the list of processed
2920 Append_New_Elmt
(Item_Id
, Seen
);
2922 if Ekind
(Item_Id
) = E_Abstract_State
then
2923 Append_New_Elmt
(Item_Id
, States_Seen
);
2925 -- The variable may eventually become a constituent of a single
2926 -- protected/task type. Record the reference now and verify its
2927 -- legality when analyzing the contract of the variable
2930 elsif Ekind
(Item_Id
) = E_Variable
then
2931 Record_Possible_Part_Of_Reference
2936 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
2937 and then Present
(Encapsulating_State
(Item_Id
))
2939 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2942 end Analyze_Global_Item
;
2944 --------------------------
2945 -- Check_Duplicate_Mode --
2946 --------------------------
2948 procedure Check_Duplicate_Mode
2950 Status
: in out Boolean)
2954 SPARK_Msg_N
("duplicate global mode", Mode
);
2958 end Check_Duplicate_Mode
;
2960 -------------------------------------------------
2961 -- Check_Mode_Restriction_In_Enclosing_Context --
2962 -------------------------------------------------
2964 procedure Check_Mode_Restriction_In_Enclosing_Context
2966 Item_Id
: Entity_Id
)
2968 Context
: Entity_Id
;
2970 Inputs
: Elist_Id
:= No_Elist
;
2971 Outputs
: Elist_Id
:= No_Elist
;
2974 -- Traverse the scope stack looking for enclosing subprograms or
2975 -- tasks subject to pragma [Refined_]Global.
2977 Context
:= Scope
(Subp_Id
);
2978 while Present
(Context
) and then Context
/= Standard_Standard
loop
2980 -- For a single task type, retrieve the corresponding object to
2981 -- which pragma [Refined_]Global is attached.
2983 if Ekind
(Context
) = E_Task_Type
2984 and then Is_Single_Concurrent_Type
(Context
)
2986 Context
:= Anonymous_Object
(Context
);
2989 if Is_Subprogram_Or_Entry
(Context
)
2990 or else Ekind
(Context
) = E_Task_Type
2991 or else Is_Single_Task_Object
(Context
)
2993 Collect_Subprogram_Inputs_Outputs
2994 (Subp_Id
=> Context
,
2995 Subp_Inputs
=> Inputs
,
2996 Subp_Outputs
=> Outputs
,
2997 Global_Seen
=> Dummy
);
2999 -- The item is classified as In_Out or Output but appears as
3000 -- an Input or a formal parameter of mode IN in an enclosing
3001 -- subprogram or task unit (SPARK RM 6.1.4(13)).
3003 if Appears_In
(Inputs
, Item_Id
)
3004 and then not Appears_In
(Outputs
, Item_Id
)
3007 ("global item & cannot have mode In_Out or Output",
3010 if Is_Subprogram_Or_Entry
(Context
) then
3012 (Fix_Msg
(Subp_Id
, "\item already appears as input "
3013 & "of subprogram &"), Item
, Context
);
3016 (Fix_Msg
(Subp_Id
, "\item already appears as input "
3017 & "of task &"), Item
, Context
);
3020 -- Stop the traversal once an error has been detected
3026 Context
:= Scope
(Context
);
3028 end Check_Mode_Restriction_In_Enclosing_Context
;
3030 ----------------------------------------
3031 -- Check_Mode_Restriction_In_Function --
3032 ----------------------------------------
3034 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
3036 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
3037 and then not Is_Function_With_Side_Effects
(Spec_Id
)
3039 Error_Msg_Code
:= GEC_Output_In_Function_Global_Or_Depends
;
3041 ("global mode & is not applicable to function '[[]']", Mode
);
3043 end Check_Mode_Restriction_In_Function
;
3051 -- Start of processing for Analyze_Global_List
3054 if Nkind
(List
) = N_Null
then
3055 Set_Analyzed
(List
);
3057 -- Single global item declaration
3059 elsif Nkind
(List
) in N_Expanded_Name
3061 | N_Selected_Component
3063 Analyze_Global_Item
(List
, Global_Mode
);
3065 -- Simple global list or moded global list declaration
3067 elsif Nkind
(List
) = N_Aggregate
then
3068 Set_Analyzed
(List
);
3070 -- The declaration of a simple global list appear as a collection
3073 if Present
(Expressions
(List
)) then
3074 if Present
(Component_Associations
(List
)) then
3076 ("cannot mix moded and non-moded global lists", List
);
3079 Item
:= First
(Expressions
(List
));
3080 while Present
(Item
) loop
3081 Analyze_Global_Item
(Item
, Global_Mode
);
3085 -- The declaration of a moded global list appears as a collection
3086 -- of component associations where individual choices denote
3089 elsif Present
(Component_Associations
(List
)) then
3090 if Present
(Expressions
(List
)) then
3092 ("cannot mix moded and non-moded global lists", List
);
3095 Assoc
:= First
(Component_Associations
(List
));
3096 while Present
(Assoc
) loop
3097 Mode
:= First
(Choices
(Assoc
));
3099 if Nkind
(Mode
) = N_Identifier
then
3100 if Chars
(Mode
) = Name_In_Out
then
3101 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
3102 Check_Mode_Restriction_In_Function
(Mode
);
3104 elsif Chars
(Mode
) = Name_Input
then
3105 Check_Duplicate_Mode
(Mode
, Input_Seen
);
3107 elsif Chars
(Mode
) = Name_Output
then
3108 Check_Duplicate_Mode
(Mode
, Output_Seen
);
3109 Check_Mode_Restriction_In_Function
(Mode
);
3111 elsif Chars
(Mode
) = Name_Proof_In
then
3112 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
3115 SPARK_Msg_N
("invalid mode selector", Mode
);
3119 SPARK_Msg_N
("invalid mode selector", Mode
);
3122 -- Items in a moded list appear as a collection of
3123 -- expressions. Reuse the existing machinery to analyze
3127 (List
=> Expression
(Assoc
),
3128 Global_Mode
=> Chars
(Mode
));
3136 raise Program_Error
;
3139 -- Any other attempt to declare a global item is illegal. This is a
3140 -- syntax error, always report.
3143 Error_Msg_N
("malformed global list", List
);
3145 end Analyze_Global_List
;
3149 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
3151 Restore_Scope
: Boolean := False;
3153 -- Start of processing for Analyze_Global_In_Decl_Part
3156 -- Do not analyze the pragma multiple times
3158 if Is_Analyzed_Pragma
(N
) then
3162 -- There is nothing to be done for a null global list
3164 if Nkind
(Items
) = N_Null
then
3165 Set_Analyzed
(Items
);
3167 -- Analyze the various forms of global lists and items. Note that some
3168 -- of these may be malformed in which case the analysis emits error
3172 -- When pragma [Refined_]Global appears on a single concurrent type,
3173 -- it is relocated to the anonymous object.
3175 if Is_Single_Concurrent_Object
(Spec_Id
) then
3178 -- Ensure that the formal parameters are visible when processing an
3179 -- item. This falls out of the general rule of aspects pertaining to
3180 -- subprogram declarations.
3182 elsif not In_Open_Scopes
(Spec_Id
) then
3183 Restore_Scope
:= True;
3184 Push_Scope
(Spec_Id
);
3186 if Ekind
(Spec_Id
) = E_Task_Type
then
3188 -- Task discriminants cannot appear in the [Refined_]Global
3189 -- contract, but must be present for the analysis so that we
3190 -- can reject them with an informative error message.
3192 if Has_Discriminants
(Spec_Id
) then
3193 Install_Discriminants
(Spec_Id
);
3196 elsif Is_Generic_Subprogram
(Spec_Id
) then
3197 Install_Generic_Formals
(Spec_Id
);
3200 Install_Formals
(Spec_Id
);
3204 Analyze_Global_List
(Items
);
3206 if Restore_Scope
then
3211 -- Ensure that a state and a corresponding constituent do not appear
3212 -- together in pragma [Refined_]Global.
3214 Check_State_And_Constituent_Use
3215 (States
=> States_Seen
,
3216 Constits
=> Constits_Seen
,
3219 Set_Is_Analyzed_Pragma
(N
);
3220 end Analyze_Global_In_Decl_Part
;
3222 ---------------------------------
3223 -- Analyze_If_Present_Internal --
3224 ---------------------------------
3226 procedure Analyze_If_Present_Internal
3234 pragma Assert
(Is_List_Member
(N
));
3236 -- Inspect the declarations or statements following pragma N looking
3237 -- for another pragma whose Id matches the caller's request. If it is
3238 -- available, analyze it.
3246 while Present
(Stmt
) loop
3247 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
3248 Analyze_Pragma
(Stmt
);
3251 -- The first source declaration or statement immediately following
3252 -- N ends the region where a pragma may appear.
3254 elsif Comes_From_Source
(Stmt
) then
3260 end Analyze_If_Present_Internal
;
3262 --------------------------------------------
3263 -- Analyze_Initial_Condition_In_Decl_Part --
3264 --------------------------------------------
3266 -- WARNING: This routine manages Ghost regions. Return statements must be
3267 -- replaced by gotos which jump to the end of the routine and restore the
3270 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
3271 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3272 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3273 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3275 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3276 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
3277 -- Save the Ghost-related attributes to restore on exit
3280 -- Do not analyze the pragma multiple times
3282 if Is_Analyzed_Pragma
(N
) then
3286 -- Set the Ghost mode in effect from the pragma. Due to the delayed
3287 -- analysis of the pragma, the Ghost mode at point of declaration and
3288 -- point of analysis may not necessarily be the same. Use the mode in
3289 -- effect at the point of declaration.
3293 -- The expression is preanalyzed because it has not been moved to its
3294 -- final place yet. A direct analysis may generate side effects and this
3295 -- is not desired at this point.
3297 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
3298 Set_Is_Analyzed_Pragma
(N
);
3300 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
3301 end Analyze_Initial_Condition_In_Decl_Part
;
3303 --------------------------------------
3304 -- Analyze_Initializes_In_Decl_Part --
3305 --------------------------------------
3307 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
3308 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3309 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3311 Constits_Seen
: Elist_Id
:= No_Elist
;
3312 -- A list containing the entities of all constituents processed so far.
3313 -- It aids in detecting illegal usage of a state and a corresponding
3314 -- constituent in pragma Initializes.
3316 Items_Seen
: Elist_Id
:= No_Elist
;
3317 -- A list of all initialization items processed so far. This list is
3318 -- used to detect duplicate items.
3320 States_And_Objs
: Elist_Id
:= No_Elist
;
3321 -- A list of all abstract states and objects declared in the visible
3322 -- declarations of the related package. This list is used to detect the
3323 -- legality of initialization items.
3325 States_Seen
: Elist_Id
:= No_Elist
;
3326 -- A list containing the entities of all states processed so far. It
3327 -- helps in detecting illegal usage of a state and a corresponding
3328 -- constituent in pragma Initializes.
3330 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
3331 -- Verify the legality of a single initialization item
3333 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
3334 -- Verify the legality of a single initialization item followed by a
3335 -- list of input items.
3337 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
);
3338 -- Inspect the visible declarations of the related package and gather
3339 -- the entities of all abstract states and objects in States_And_Objs.
3341 ---------------------------------
3342 -- Analyze_Initialization_Item --
3343 ---------------------------------
3345 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
3346 Item_Id
: Entity_Id
;
3350 Resolve_State
(Item
);
3352 if Is_Entity_Name
(Item
) then
3353 Item_Id
:= Entity_Of
(Item
);
3355 if Present
(Item_Id
)
3356 and then Ekind
(Item_Id
) in
3357 E_Abstract_State | E_Constant | E_Variable
3359 -- When the initialization item is undefined, it appears as
3360 -- Any_Id. Do not continue with the analysis of the item.
3362 if Item_Id
= Any_Id
then
3365 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
3366 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
3369 ("overlaying object & cannot appear in Initializes",
3372 ("\use the overlaid object & instead",
3373 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
3375 -- The state or variable must be declared in the visible
3376 -- declarations of the package (SPARK RM 7.1.5(7)).
3378 elsif not Contains
(States_And_Objs
, Item_Id
) then
3379 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3381 ("initialization item & must appear in the visible "
3382 & "declarations of package %", Item
, Item_Id
);
3384 -- Detect a duplicate use of the same initialization item
3385 -- (SPARK RM 7.1.5(5)).
3387 elsif Contains
(Items_Seen
, Item_Id
) then
3388 SPARK_Msg_N
("duplicate initialization item", Item
);
3390 -- The item is legal, add it to the list of processed states
3394 Append_New_Elmt
(Item_Id
, Items_Seen
);
3396 if Ekind
(Item_Id
) = E_Abstract_State
then
3397 Append_New_Elmt
(Item_Id
, States_Seen
);
3400 if Present
(Encapsulating_State
(Item_Id
)) then
3401 Append_New_Elmt
(Item_Id
, Constits_Seen
);
3405 -- The item references something that is not a state or object
3406 -- (SPARK RM 7.1.5(3)).
3410 ("initialization item must denote object or state", Item
);
3413 -- Some form of illegal construct masquerading as a name
3414 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3418 ("initialization item must denote object or state", Item
);
3420 end Analyze_Initialization_Item
;
3422 ---------------------------------------------
3423 -- Analyze_Initialization_Item_With_Inputs --
3424 ---------------------------------------------
3426 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
3427 Inputs_Seen
: Elist_Id
:= No_Elist
;
3428 -- A list of all inputs processed so far. This list is used to detect
3429 -- duplicate uses of an input.
3431 Non_Null_Seen
: Boolean := False;
3432 Null_Seen
: Boolean := False;
3433 -- Flags used to check the legality of an input list
3435 procedure Analyze_Input_Item
(Input
: Node_Id
);
3436 -- Verify the legality of a single input item
3438 ------------------------
3439 -- Analyze_Input_Item --
3440 ------------------------
3442 procedure Analyze_Input_Item
(Input
: Node_Id
) is
3443 Input_Id
: Entity_Id
;
3448 if Nkind
(Input
) = N_Null
then
3451 ("multiple null initializations not allowed", Item
);
3453 elsif Non_Null_Seen
then
3455 ("cannot mix null and non-null initialization item", Item
);
3463 Non_Null_Seen
:= True;
3467 ("cannot mix null and non-null initialization item", Item
);
3471 Resolve_State
(Input
);
3473 if Is_Entity_Name
(Input
) then
3474 Input_Id
:= Entity_Of
(Input
);
3476 if Present
(Input_Id
)
3477 and then Ekind
(Input_Id
) in E_Abstract_State
3479 | E_Generic_In_Out_Parameter
3480 | E_Generic_In_Parameter
3482 | E_In_Out_Parameter
3488 -- The input cannot denote states or objects declared
3489 -- within the related package (SPARK RM 7.1.5(4)).
3491 if Within_Scope
(Input_Id
, Current_Scope
) then
3493 -- Do not consider generic formal parameters or their
3494 -- respective mappings to generic formals. Even though
3495 -- the formals appear within the scope of the package,
3496 -- it is allowed for an initialization item to depend
3497 -- on an input item.
3499 if Is_Formal_Object
(Input_Id
) then
3502 elsif Ekind
(Input_Id
) in E_Constant | E_Variable
3503 and then Present
(Corresponding_Generic_Association
3504 (Declaration_Node
(Input_Id
)))
3509 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3511 ("input item & cannot denote a visible object or "
3512 & "state of package %", Input
, Input_Id
);
3517 if Ekind
(Input_Id
) in E_Constant | E_Variable
3518 and then Present
(Ultimate_Overlaid_Entity
(Input_Id
))
3521 ("overlaying object & cannot appear in Initializes",
3524 ("\use the overlaid object & instead",
3525 Input
, Ultimate_Overlaid_Entity
(Input_Id
));
3529 -- Detect a duplicate use of the same input item
3530 -- (SPARK RM 7.1.5(5)).
3532 if Contains
(Inputs_Seen
, Input_Id
) then
3533 SPARK_Msg_N
("duplicate input item", Input
);
3537 -- At this point it is known that the input is legal. Add
3538 -- it to the list of processed inputs.
3540 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
3542 if Ekind
(Input_Id
) = E_Abstract_State
then
3543 Append_New_Elmt
(Input_Id
, States_Seen
);
3546 if Ekind
(Input_Id
) in E_Abstract_State
3549 and then Present
(Encapsulating_State
(Input_Id
))
3551 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3554 -- The input references something that is not a state or an
3555 -- object (SPARK RM 7.1.5(3)).
3559 ("input item must denote object or state", Input
);
3562 -- Some form of illegal construct masquerading as a name
3563 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3567 ("input item must denote object or state", Input
);
3570 end Analyze_Input_Item
;
3574 Inputs
: constant Node_Id
:= Expression
(Item
);
3578 Name_Seen
: Boolean := False;
3579 -- A flag used to detect multiple item names
3581 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3584 -- Inspect the name of an item with inputs
3586 Elmt
:= First
(Choices
(Item
));
3587 while Present
(Elmt
) loop
3589 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3592 Analyze_Initialization_Item
(Elmt
);
3598 -- Multiple input items appear as an aggregate
3600 if Nkind
(Inputs
) = N_Aggregate
then
3601 if Present
(Expressions
(Inputs
)) then
3602 Input
:= First
(Expressions
(Inputs
));
3603 while Present
(Input
) loop
3604 Analyze_Input_Item
(Input
);
3609 if Present
(Component_Associations
(Inputs
)) then
3611 ("inputs must appear in named association form", Inputs
);
3614 -- Single input item
3617 Analyze_Input_Item
(Inputs
);
3619 end Analyze_Initialization_Item_With_Inputs
;
3621 --------------------------------
3622 -- Collect_States_And_Objects --
3623 --------------------------------
3625 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
) is
3626 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3627 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3629 State_Elmt
: Elmt_Id
;
3632 -- Collect the abstract states defined in the package (if any)
3634 if Has_Non_Null_Abstract_State
(Pack_Id
) then
3635 State_Elmt
:= First_Elmt
(Abstract_States
(Pack_Id
));
3636 while Present
(State_Elmt
) loop
3637 Append_New_Elmt
(Node
(State_Elmt
), States_And_Objs
);
3638 Next_Elmt
(State_Elmt
);
3642 -- Collect all objects that appear in the visible declarations of the
3645 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3646 while Present
(Decl
) loop
3647 if Comes_From_Source
(Decl
)
3648 and then Nkind
(Decl
) in N_Object_Declaration
3649 | N_Object_Renaming_Declaration
3651 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3653 elsif Nkind
(Decl
) = N_Package_Declaration
then
3654 Collect_States_And_Objects
(Decl
);
3656 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3658 (Anonymous_Object
(Defining_Entity
(Decl
)),
3664 end Collect_States_And_Objects
;
3668 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3671 -- Start of processing for Analyze_Initializes_In_Decl_Part
3674 -- Do not analyze the pragma multiple times
3676 if Is_Analyzed_Pragma
(N
) then
3680 -- Nothing to do when the initialization list is empty
3682 if Nkind
(Inits
) = N_Null
then
3686 -- Single and multiple initialization clauses appear as an aggregate. If
3687 -- this is not the case, then either the parser or the analysis of the
3688 -- pragma failed to produce an aggregate.
3690 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3692 -- Initialize the various lists used during analysis
3694 Collect_States_And_Objects
(Pack_Decl
);
3696 if Present
(Expressions
(Inits
)) then
3697 Init
:= First
(Expressions
(Inits
));
3698 while Present
(Init
) loop
3699 Analyze_Initialization_Item
(Init
);
3704 if Present
(Component_Associations
(Inits
)) then
3705 Init
:= First
(Component_Associations
(Inits
));
3706 while Present
(Init
) loop
3707 Analyze_Initialization_Item_With_Inputs
(Init
);
3712 -- Ensure that a state and a corresponding constituent do not appear
3713 -- together in pragma Initializes.
3715 Check_State_And_Constituent_Use
3716 (States
=> States_Seen
,
3717 Constits
=> Constits_Seen
,
3720 Set_Is_Analyzed_Pragma
(N
);
3721 end Analyze_Initializes_In_Decl_Part
;
3723 ---------------------
3724 -- Analyze_Part_Of --
3725 ---------------------
3727 procedure Analyze_Part_Of
3729 Item_Id
: Entity_Id
;
3731 Encap_Id
: out Entity_Id
;
3732 Legal
: out Boolean)
3734 procedure Check_Part_Of_Abstract_State
;
3735 pragma Inline
(Check_Part_Of_Abstract_State
);
3736 -- Verify the legality of indicator Part_Of when the encapsulator is an
3739 procedure Check_Part_Of_Concurrent_Type
;
3740 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3741 -- Verify the legality of indicator Part_Of when the encapsulator is a
3742 -- single concurrent type.
3744 ----------------------------------
3745 -- Check_Part_Of_Abstract_State --
3746 ----------------------------------
3748 procedure Check_Part_Of_Abstract_State
is
3749 Pack_Id
: Entity_Id
;
3750 Placement
: State_Space_Kind
;
3751 Parent_Unit
: Entity_Id
;
3754 -- Determine where the object, package instantiation or state lives
3755 -- with respect to the enclosing packages or package bodies.
3757 Find_Placement_In_State_Space
3758 (Item_Id
=> Item_Id
,
3759 Placement
=> Placement
,
3760 Pack_Id
=> Pack_Id
);
3762 -- The item appears in a non-package construct with a declarative
3763 -- part (subprogram, block, etc). As such, the item is not allowed
3764 -- to be a part of an encapsulating state because the item is not
3767 if Placement
= Not_In_Package
then
3769 ("indicator Part_Of cannot appear in this context "
3770 & "(SPARK RM 7.2.6(5))", Indic
);
3772 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3774 ("\& is not part of the hidden state of package %",
3778 -- The item appears in the visible state space of some package. In
3779 -- general this scenario does not warrant Part_Of except when the
3780 -- package is a nongeneric private child unit and the encapsulating
3781 -- state is declared in a parent unit or a public descendant of that
3784 elsif Placement
= Visible_State_Space
then
3785 if Is_Child_Unit
(Pack_Id
)
3786 and then not Is_Generic_Unit
(Pack_Id
)
3787 and then Is_Private_Descendant
(Pack_Id
)
3789 -- A variable or state abstraction which is part of the visible
3790 -- state of a nongeneric private child unit or its public
3791 -- descendants must have its Part_Of indicator specified. The
3792 -- Part_Of indicator must denote a state declared by either the
3793 -- parent unit of the private unit or by a public descendant of
3794 -- that parent unit.
3796 -- Find the nearest private ancestor (which can be the current
3799 Parent_Unit
:= Pack_Id
;
3800 while Present
(Parent_Unit
) loop
3801 exit when Is_Private_Library_Unit
(Parent_Unit
);
3802 Parent_Unit
:= Scope
(Parent_Unit
);
3805 Parent_Unit
:= Scope
(Parent_Unit
);
3807 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3809 ("indicator Part_Of must denote abstract state of & or of "
3810 & "its public descendant (SPARK RM 7.2.6(3))",
3811 Indic
, Parent_Unit
);
3814 elsif Scope
(Encap_Id
) = Parent_Unit
3816 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3817 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3823 ("indicator Part_Of must denote abstract state of & or of "
3824 & "its public descendant (SPARK RM 7.2.6(3))",
3825 Indic
, Parent_Unit
);
3829 -- Indicator Part_Of is not needed when the related package is
3830 -- not a nongeneric private child unit or a public descendant
3835 ("indicator Part_Of cannot appear in this context "
3836 & "(SPARK RM 7.2.6(5))", Indic
);
3838 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3840 ("\& is declared in the visible part of package %",
3845 -- When the item appears in the private state space of a package, the
3846 -- encapsulating state must be declared in the same package.
3848 elsif Placement
= Private_State_Space
then
3850 -- In the case of the abstract state of a nongeneric private
3851 -- child package, it may be encapsulated in the state of a
3852 -- public descendant of its parent package.
3855 function Is_Public_Descendant
3856 (Child
, Ancestor
: Entity_Id
)
3858 -- Return True if Child is a public descendant of Pack
3860 --------------------------
3861 -- Is_Public_Descendant --
3862 --------------------------
3864 function Is_Public_Descendant
3865 (Child
, Ancestor
: Entity_Id
)
3868 P
: Entity_Id
:= Child
;
3870 while Is_Child_Unit
(P
)
3871 and then not Is_Private_Library_Unit
(P
)
3873 if Scope
(P
) = Ancestor
then
3881 end Is_Public_Descendant
;
3885 Immediate_Pack_Id
: constant Entity_Id
:= Scope
(Item_Id
);
3887 Is_State_Of_Private_Child
: constant Boolean :=
3888 Is_Child_Unit
(Immediate_Pack_Id
)
3889 and then not Is_Generic_Unit
(Immediate_Pack_Id
)
3890 and then Is_Private_Descendant
(Immediate_Pack_Id
);
3892 Is_OK_Through_Sibling
: Boolean := False;
3895 if Ekind
(Item_Id
) = E_Abstract_State
3896 and then Is_State_Of_Private_Child
3897 and then Is_Public_Descendant
(Scope
(Encap_Id
), Pack_Id
)
3899 Is_OK_Through_Sibling
:= True;
3902 if Scope
(Encap_Id
) /= Pack_Id
3903 and then not Is_OK_Through_Sibling
3905 if Is_State_Of_Private_Child
then
3907 ("indicator Part_Of must denote abstract state of & "
3908 & "or of its public descendant "
3909 & "(SPARK RM 7.2.6(3))", Indic
, Pack_Id
);
3912 ("indicator Part_Of must denote an abstract state of "
3913 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3916 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3918 ("\& is declared in the private part of package %",
3924 -- Items declared in the body state space of a package do not need
3925 -- Part_Of indicators as the refinement has already been seen.
3929 ("indicator Part_Of cannot appear in this context "
3930 & "(SPARK RM 7.2.6(5))", Indic
);
3932 if Scope
(Encap_Id
) = Pack_Id
then
3933 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3935 ("\& is declared in the body of package %", Indic
, Item_Id
);
3941 -- In the case of state in a (descendant of a private) child which
3942 -- is Part_Of the state of another package, the package defining the
3943 -- encapsulating abstract state should have a body, to ensure that it
3944 -- has a state refinement (SPARK RM 7.1.4(4)).
3946 if Enclosing_Comp_Unit_Node
(Encap_Id
) /=
3947 Enclosing_Comp_Unit_Node
(Item_Id
)
3948 and then not Unit_Requires_Body
(Scope
(Encap_Id
))
3951 ("indicator Part_Of must denote abstract state of package "
3952 & "with a body (SPARK RM 7.1.4(4))", Indic
);
3956 -- At this point it is known that the Part_Of indicator is legal
3959 end Check_Part_Of_Abstract_State
;
3961 -----------------------------------
3962 -- Check_Part_Of_Concurrent_Type --
3963 -----------------------------------
3965 procedure Check_Part_Of_Concurrent_Type
is
3966 function In_Proper_Order
3968 Second
: Node_Id
) return Boolean;
3969 pragma Inline
(In_Proper_Order
);
3970 -- Determine whether node First precedes node Second
3972 procedure Placement_Error
;
3973 pragma Inline
(Placement_Error
);
3974 -- Emit an error concerning the illegal placement of the item with
3975 -- respect to the single concurrent type.
3977 ---------------------
3978 -- In_Proper_Order --
3979 ---------------------
3981 function In_Proper_Order
3983 Second
: Node_Id
) return Boolean
3988 if List_Containing
(First
) = List_Containing
(Second
) then
3990 while Present
(N
) loop
4000 end In_Proper_Order
;
4002 ---------------------
4003 -- Placement_Error --
4004 ---------------------
4006 procedure Placement_Error
is
4009 ("indicator Part_Of must denote a previously declared single "
4010 & "protected type or single task type", Encap
);
4011 end Placement_Error
;
4015 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
4016 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
4017 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
4019 Item_Context
: Node_Id
;
4020 Item_Decl
: Node_Id
;
4021 Prv_Decls
: List_Id
;
4022 Vis_Decls
: List_Id
;
4024 -- Start of processing for Check_Part_Of_Concurrent_Type
4027 -- Only abstract states and variables can act as constituents of an
4028 -- encapsulating single concurrent type.
4030 if Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
4033 -- The constituent is a constant
4035 elsif Ekind
(Item_Id
) = E_Constant
then
4036 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4038 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
4039 & "single protected type %"), Indic
, Item_Id
);
4042 -- The constituent is a package instantiation
4045 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4047 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
4048 & "constituent of single protected type %"), Indic
, Item_Id
);
4052 -- When the item denotes an abstract state of a nested package, use
4053 -- the declaration of the package to detect proper placement.
4058 -- with Abstract_State => (State with Part_Of => T)
4060 if Ekind
(Item_Id
) = E_Abstract_State
then
4061 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
4063 Item_Decl
:= Declaration_Node
(Item_Id
);
4066 Item_Context
:= Parent
(Item_Decl
);
4068 -- The item and the single concurrent type must appear in the same
4069 -- declarative region, with the item following the declaration of
4070 -- the single concurrent type (SPARK RM 9(3)).
4072 if Item_Context
= Encap_Context
then
4073 if Nkind
(Item_Context
) in N_Package_Specification
4074 | N_Protected_Definition
4077 Prv_Decls
:= Private_Declarations
(Item_Context
);
4078 Vis_Decls
:= Visible_Declarations
(Item_Context
);
4080 -- The placement is OK when the single concurrent type appears
4081 -- within the visible declarations and the item in the private
4087 -- Constit : ... with Part_Of => PO;
4090 if List_Containing
(Encap_Decl
) = Vis_Decls
4091 and then List_Containing
(Item_Decl
) = Prv_Decls
4095 -- The placement is illegal when the item appears within the
4096 -- visible declarations and the single concurrent type is in
4097 -- the private declarations.
4100 -- Constit : ... with Part_Of => PO;
4105 elsif List_Containing
(Item_Decl
) = Vis_Decls
4106 and then List_Containing
(Encap_Decl
) = Prv_Decls
4111 -- Otherwise both the item and the single concurrent type are
4112 -- in the same list. Ensure that the declaration of the single
4113 -- concurrent type precedes that of the item.
4115 elsif not In_Proper_Order
4116 (First
=> Encap_Decl
,
4117 Second
=> Item_Decl
)
4123 -- Otherwise both the item and the single concurrent type are
4124 -- in the same list. Ensure that the declaration of the single
4125 -- concurrent type precedes that of the item.
4127 elsif not In_Proper_Order
4128 (First
=> Encap_Decl
,
4129 Second
=> Item_Decl
)
4135 -- Otherwise the item and the single concurrent type reside within
4136 -- unrelated regions.
4139 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4141 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
4142 & "immediately within the same region as single protected "
4143 & "type %"), Indic
, Item_Id
);
4147 -- At this point it is known that the Part_Of indicator is legal
4150 end Check_Part_Of_Concurrent_Type
;
4152 -- Start of processing for Analyze_Part_Of
4155 -- Assume that the indicator is illegal
4161 N_Expanded_Name | N_Identifier | N_Selected_Component
4164 Resolve_State
(Encap
);
4166 Encap_Id
:= Entity
(Encap
);
4168 -- The encapsulator is an abstract state
4170 if Ekind
(Encap_Id
) = E_Abstract_State
then
4173 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
4175 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
4178 -- Otherwise the encapsulator is not a legal choice
4182 ("indicator Part_Of must denote abstract state, single "
4183 & "protected type or single task type", Encap
);
4187 -- This is a syntax error, always report
4191 ("indicator Part_Of must denote abstract state, single protected "
4192 & "type or single task type", Encap
);
4196 -- Catch a case where indicator Part_Of denotes the abstract view of a
4197 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
4199 if From_Limited_With
(Encap_Id
)
4200 and then Present
(Non_Limited_View
(Encap_Id
))
4201 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
4203 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
4204 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
4208 -- The encapsulator is an abstract state
4210 if Ekind
(Encap_Id
) = E_Abstract_State
then
4211 Check_Part_Of_Abstract_State
;
4213 -- The encapsulator is a single concurrent type
4216 Check_Part_Of_Concurrent_Type
;
4218 end Analyze_Part_Of
;
4220 ----------------------------------
4221 -- Analyze_Part_Of_In_Decl_Part --
4222 ----------------------------------
4224 procedure Analyze_Part_Of_In_Decl_Part
4226 Freeze_Id
: Entity_Id
:= Empty
)
4228 Encap
: constant Node_Id
:=
4229 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
4230 Errors
: constant Nat
:= Serious_Errors_Detected
;
4231 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
4232 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
4233 Constits
: Elist_Id
;
4234 Encap_Id
: Entity_Id
;
4238 -- Detect any discrepancies between the placement of the variable with
4239 -- respect to general state space and the encapsulating state or single
4246 Encap_Id
=> Encap_Id
,
4249 -- The Part_Of indicator turns the variable into a constituent of the
4250 -- encapsulating state or single concurrent type.
4253 pragma Assert
(Present
(Encap_Id
));
4254 Constits
:= Part_Of_Constituents
(Encap_Id
);
4256 if No
(Constits
) then
4257 Constits
:= New_Elmt_List
;
4258 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
4261 Append_Elmt
(Var_Id
, Constits
);
4262 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
4264 -- A Part_Of constituent partially refines an abstract state. This
4265 -- property does not apply to protected or task units.
4267 if Ekind
(Encap_Id
) = E_Abstract_State
then
4268 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
4272 -- Emit a clarification message when the encapsulator is undefined,
4273 -- possibly due to contract freezing.
4275 if Errors
/= Serious_Errors_Detected
4276 and then Present
(Freeze_Id
)
4277 and then Has_Undefined_Reference
(Encap
)
4279 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
4281 end Analyze_Part_Of_In_Decl_Part
;
4283 --------------------
4284 -- Analyze_Pragma --
4285 --------------------
4287 procedure Analyze_Pragma
(N
: Node_Id
) is
4288 Loc
: constant Source_Ptr
:= Sloc
(N
);
4290 Pname
: Name_Id
:= Pragma_Name
(N
);
4291 -- Name of the source pragma, or name of the corresponding aspect for
4292 -- pragmas which originate in a source aspect. In the latter case, the
4293 -- name may be different from the pragma name.
4295 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
4297 Pragma_Exit
: exception;
4298 -- This exception is used to exit pragma processing completely. It
4299 -- is used when an error is detected, and no further processing is
4300 -- required. It is also used if an earlier error has left the tree in
4301 -- a state where the pragma should not be processed.
4304 -- Number of pragma argument associations
4311 -- First five pragma arguments (pragma argument association nodes, or
4312 -- Empty if the corresponding argument does not exist).
4314 type Name_List
is array (Natural range <>) of Name_Id
;
4315 type Args_List
is array (Natural range <>) of Node_Id
;
4316 -- Types used for arguments to Check_Arg_Order and Gather_Associations
4318 -----------------------
4319 -- Local Subprograms --
4320 -----------------------
4322 procedure Ada_2005_Pragma
;
4323 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
4324 -- Ada 95 mode, these are implementation defined pragmas, so should be
4325 -- caught by the No_Implementation_Pragmas restriction.
4327 procedure Ada_2012_Pragma
;
4328 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
4329 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
4330 -- should be caught by the No_Implementation_Pragmas restriction.
4332 procedure Analyze_Depends_Global
4333 (Spec_Id
: out Entity_Id
;
4334 Subp_Decl
: out Node_Id
;
4335 Legal
: out Boolean);
4336 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
4337 -- legality of the placement and related context of the pragma. Spec_Id
4338 -- is the entity of the related subprogram. Subp_Decl is the declaration
4339 -- of the related subprogram. Sets flag Legal when the pragma is legal.
4341 procedure Analyze_If_Present
(Id
: Pragma_Id
);
4342 -- Inspect the remainder of the list containing pragma N and look for
4343 -- a pragma that matches Id. If found, analyze the pragma.
4345 procedure Analyze_Pre_Post_Condition
;
4346 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
4348 procedure Analyze_Refined_Depends_Global_Post
4349 (Spec_Id
: out Entity_Id
;
4350 Body_Id
: out Entity_Id
;
4351 Legal
: out Boolean);
4352 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
4353 -- Refined_Global and Refined_Post. Verify the legality of the placement
4354 -- and related context of the pragma. Spec_Id is the entity of the
4355 -- related subprogram. Body_Id is the entity of the subprogram body.
4356 -- Flag Legal is set when the pragma is legal.
4358 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
4359 -- Perform full analysis of pragma Unmodified and the write aspect of
4360 -- pragma Unused. Flag Is_Unused should be set when verifying the
4361 -- semantics of pragma Unused.
4363 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
4364 -- Perform full analysis of pragma Unreferenced and the read aspect of
4365 -- pragma Unused. Flag Is_Unused should be set when verifying the
4366 -- semantics of pragma Unused.
4368 procedure Check_Ada_83_Warning
;
4369 -- Issues a warning message for the current pragma if operating in Ada
4370 -- 83 mode (used for language pragmas that are not a standard part of
4371 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
4374 procedure Check_Arg_Count
(Required
: Nat
);
4375 -- Check argument count for pragma is equal to given parameter. If not,
4376 -- then issue an error message and raise Pragma_Exit.
4378 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
4379 -- Arg which can either be a pragma argument association, in which case
4380 -- the check is applied to the expression of the association or an
4381 -- expression directly.
4383 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
4384 -- Check that an argument has the right form for an EXTERNAL_NAME
4385 -- parameter of an extended import/export pragma. The rule is that the
4386 -- name must be an identifier or string literal (in Ada 83 mode) or a
4387 -- static string expression (in Ada 95 mode).
4389 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
4390 -- Check the specified argument Arg to make sure that it is an
4391 -- identifier. If not give error and raise Pragma_Exit.
4393 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
4394 -- Check the specified argument Arg to make sure that it is an integer
4395 -- literal. If not give error and raise Pragma_Exit.
4397 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
4398 -- Check the specified argument Arg to make sure that it has the proper
4399 -- syntactic form for a local name and meets the semantic requirements
4400 -- for a local name. The local name is analyzed as part of the
4401 -- processing for this call. In addition, the local name is required
4402 -- to represent an entity at the library level.
4404 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
4405 -- Check the specified argument Arg to make sure that it has the proper
4406 -- syntactic form for a local name and meets the semantic requirements
4407 -- for a local name. The local name is analyzed as part of the
4408 -- processing for this call.
4410 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
4411 -- Check the specified argument Arg to make sure that it is a valid
4412 -- locking policy name. If not give error and raise Pragma_Exit.
4414 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
4415 -- Check the specified argument Arg to make sure that it is a valid
4416 -- elaboration policy name. If not give error and raise Pragma_Exit.
4418 procedure Check_Arg_Is_One_Of
4421 procedure Check_Arg_Is_One_Of
4423 N1
, N2
, N3
: Name_Id
);
4424 procedure Check_Arg_Is_One_Of
4426 N1
, N2
, N3
, N4
: Name_Id
);
4427 procedure Check_Arg_Is_One_Of
4429 N1
, N2
, N3
, N4
, N5
: Name_Id
);
4430 -- Check the specified argument Arg to make sure that it is an
4431 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
4432 -- present). If not then give error and raise Pragma_Exit.
4434 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
4435 -- Check the specified argument Arg to make sure that it is a valid
4436 -- queuing policy name. If not give error and raise Pragma_Exit.
4438 procedure Check_Arg_Is_OK_Static_Expression
4440 Typ
: Entity_Id
:= Empty
);
4441 -- Check the specified argument Arg to make sure that it is a static
4442 -- expression of the given type (i.e. it will be analyzed and resolved
4443 -- using this type, which can be any valid argument to Resolve, e.g.
4444 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4445 -- Typ is left Empty, then any static expression is allowed. Includes
4446 -- checking that the argument does not raise Constraint_Error.
4448 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
4449 -- Check the specified argument Arg to make sure that it is a valid task
4450 -- dispatching policy name. If not give error and raise Pragma_Exit.
4452 procedure Check_Arg_Order
(Names
: Name_List
);
4453 -- Checks for an instance of two arguments with identifiers for the
4454 -- current pragma which are not in the sequence indicated by Names,
4455 -- and if so, generates a fatal message about bad order of arguments.
4457 procedure Check_At_Least_N_Arguments
(N
: Nat
);
4458 -- Check there are at least N arguments present
4460 procedure Check_At_Most_N_Arguments
(N
: Nat
);
4461 -- Check there are no more than N arguments present
4463 procedure Check_Component
4466 In_Variant_Part
: Boolean := False);
4467 -- Examine an Unchecked_Union component for correct use of per-object
4468 -- constrained subtypes, and for restrictions on finalizable components.
4469 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
4470 -- should be set when Comp comes from a record variant.
4472 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
4473 -- Check if a rep item of the same name as the current pragma is already
4474 -- chained as a rep pragma to the given entity. If so give a message
4475 -- about the duplicate, and then raise Pragma_Exit so does not return.
4476 -- Note that if E is a type, then this routine avoids flagging a pragma
4477 -- which applies to a parent type from which E is derived.
4479 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
4480 -- Nam is an N_String_Literal node containing the external name set by
4481 -- an Import or Export pragma (or extended Import or Export pragma).
4482 -- This procedure checks for possible duplications if this is the export
4483 -- case, and if found, issues an appropriate error message.
4485 procedure Check_Expr_Is_OK_Static_Expression
4487 Typ
: Entity_Id
:= Empty
);
4488 -- Check the specified expression Expr to make sure that it is a static
4489 -- expression of the given type (i.e. it will be analyzed and resolved
4490 -- using this type, which can be any valid argument to Resolve, e.g.
4491 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4492 -- Typ is left Empty, then any static expression is allowed. Includes
4493 -- checking that the expression does not raise Constraint_Error.
4495 procedure Check_First_Subtype
(Arg
: Node_Id
);
4496 -- Checks that Arg, whose expression is an entity name, references a
4499 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4500 -- Checks that the given argument has an identifier, and if so, requires
4501 -- it to match the given identifier name. If there is no identifier, or
4502 -- a non-matching identifier, then an error message is given and
4503 -- Pragma_Exit is raised.
4505 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
4506 -- Checks that the given argument has an identifier, and if so, requires
4507 -- it to match one of the given identifier names. If there is no
4508 -- identifier, or a non-matching identifier, then an error message is
4509 -- given and Pragma_Exit is raised.
4511 procedure Check_In_Main_Program
;
4512 -- Common checks for pragmas that appear within a main program
4513 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4515 procedure Check_Interrupt_Or_Attach_Handler
;
4516 -- Common processing for first argument of pragma Interrupt_Handler or
4517 -- pragma Attach_Handler.
4519 procedure Check_Loop_Pragma_Placement
;
4520 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4521 -- appear immediately within a construct restricted to loops, and that
4522 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4524 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
4525 -- Check that pragma appears in a declarative part, or in a package
4526 -- specification, i.e. that it does not occur in a statement sequence
4529 procedure Check_No_Identifier
(Arg
: Node_Id
);
4530 -- Checks that the given argument does not have an identifier. If
4531 -- an identifier is present, then an error message is issued, and
4532 -- Pragma_Exit is raised.
4534 procedure Check_No_Identifiers
;
4535 -- Checks that none of the arguments to the pragma has an identifier.
4536 -- If any argument has an identifier, then an error message is issued,
4537 -- and Pragma_Exit is raised.
4539 procedure Check_No_Link_Name
;
4540 -- Checks that no link name is specified
4542 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4543 -- Checks if the given argument has an identifier, and if so, requires
4544 -- it to match the given identifier name. If there is a non-matching
4545 -- identifier, then an error message is given and Pragma_Exit is raised.
4547 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
4548 -- Checks if the given argument has an identifier, and if so, requires
4549 -- it to match the given identifier name. If there is a non-matching
4550 -- identifier, then an error message is given and Pragma_Exit is raised.
4551 -- In this version of the procedure, the identifier name is given as
4552 -- a string with lower case letters.
4554 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
4555 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4556 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4557 -- Extensions_Visible, Side_Effects and Volatile_Function. Ensure
4558 -- that expression Expr is an OK static boolean expression. Emit an
4559 -- error if this is not the case.
4561 procedure Check_Static_Constraint
(Constr
: Node_Id
);
4562 -- Constr is a constraint from an N_Subtype_Indication node from a
4563 -- component constraint in an Unchecked_Union type, a range, or a
4564 -- discriminant association. This routine checks that the constraint
4565 -- is static as required by the restrictions for Unchecked_Union.
4567 procedure Check_Valid_Configuration_Pragma
;
4568 -- Legality checks for placement of a configuration pragma
4570 procedure Check_Valid_Library_Unit_Pragma
;
4571 -- Legality checks for library unit pragmas. A special case arises for
4572 -- pragmas in generic instances that come from copies of the original
4573 -- library unit pragmas in the generic templates. In the case of other
4574 -- than library level instantiations these can appear in contexts which
4575 -- would normally be invalid (they only apply to the original template
4576 -- and to library level instantiations), and they are simply ignored,
4577 -- which is implemented by rewriting them as null statements and
4578 -- optionally raising Pragma_Exit to terminate analysis. An exception
4579 -- is not always raised to avoid exception propagation during the
4580 -- bootstrap, so all callers should check whether N has been rewritten.
4582 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
4583 -- Check an Unchecked_Union variant for lack of nested variants and
4584 -- presence of at least one component. UU_Typ is the related Unchecked_
4587 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
4588 -- Subsidiary routine to the processing of pragmas Abstract_State,
4589 -- Contract_Cases, Depends, Exceptional_Cases, Global, Initializes,
4590 -- Refined_Depends, Refined_Global, Refined_State and
4591 -- Subprogram_Variant. Transform argument Arg into an aggregate if not
4592 -- one already. N_Null is never transformed. Arg may denote an aspect
4593 -- specification or a pragma argument association.
4595 procedure Error_Pragma
(Msg
: String);
4596 pragma No_Return
(Error_Pragma
);
4597 -- Outputs error message for current pragma. The message contains a %
4598 -- that will be replaced with the pragma name, and the flag is placed
4599 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4600 -- calls Fix_Error (see spec of that procedure for details).
4602 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
4603 pragma No_Return
(Error_Pragma_Arg
);
4604 -- Outputs error message for current pragma. The message may contain
4605 -- a % that will be replaced with the pragma name. The parameter Arg
4606 -- may either be a pragma argument association, in which case the flag
4607 -- is placed on the expression of this association, or an expression,
4608 -- in which case the flag is placed directly on the expression. The
4609 -- message is placed using Error_Msg_N, so the message may also contain
4610 -- an & insertion character which will reference the given Arg value.
4611 -- After placing the message, Pragma_Exit is raised. Note: this routine
4612 -- calls Fix_Error (see spec of that procedure for details).
4614 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
4615 pragma No_Return
(Error_Pragma_Arg
);
4616 -- Similar to above form of Error_Pragma_Arg except that two messages
4617 -- are provided, the second is a continuation comment starting with \.
4619 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
4620 pragma No_Return
(Error_Pragma_Arg_Ident
);
4621 -- Outputs error message for current pragma. The message may contain a %
4622 -- that will be replaced with the pragma name. The parameter Arg must be
4623 -- a pragma argument association with a non-empty identifier (i.e. its
4624 -- Chars field must be set), and the error message is placed on the
4625 -- identifier. The message is placed using Error_Msg_N so the message
4626 -- may also contain an & insertion character which will reference
4627 -- the identifier. After placing the message, Pragma_Exit is raised.
4628 -- Note: this routine calls Fix_Error (see spec of that procedure for
4631 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4632 pragma No_Return
(Error_Pragma_Ref
);
4633 -- Outputs error message for current pragma. The message may contain
4634 -- a % that will be replaced with the pragma name. The parameter Ref
4635 -- must be an entity whose name can be referenced by & and sloc by #.
4636 -- After placing the message, Pragma_Exit is raised. Note: this routine
4637 -- calls Fix_Error (see spec of that procedure for details).
4639 function Find_Lib_Unit_Name
return Entity_Id
;
4640 -- Used for a library unit pragma to find the entity to which the
4641 -- library unit pragma applies, returns the entity found.
4643 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4644 -- If the pragma is a compilation unit pragma, the id must denote the
4645 -- compilation unit in the same compilation, and the pragma must appear
4646 -- in the list of preceding or trailing pragmas. If it is a program
4647 -- unit pragma that is not a compilation unit pragma, then the
4648 -- identifier must be visible.
4650 function Find_Unique_Parameterless_Procedure
4652 Arg
: Node_Id
) return Entity_Id
;
4653 -- Used for a procedure pragma to find the unique parameterless
4654 -- procedure identified by Name, returns it if it exists, otherwise
4655 -- errors out and uses Arg as the pragma argument for the message.
4657 function Fix_Error
(Msg
: String) return String;
4658 -- This is called prior to issuing an error message. Msg is the normal
4659 -- error message issued in the pragma case. This routine checks for the
4660 -- case of a pragma coming from an aspect in the source, and returns a
4661 -- message suitable for the aspect case as follows:
4663 -- Each substring "pragma" is replaced by "aspect"
4665 -- If "argument of" is at the start of the error message text, it is
4666 -- replaced by "entity for".
4668 -- If "argument" is at the start of the error message text, it is
4669 -- replaced by "entity".
4671 -- So for example, "argument of pragma X must be discrete type"
4672 -- returns "entity for aspect X must be a discrete type".
4674 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4675 -- be different from the pragma name). If the current pragma results
4676 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4677 -- original pragma name.
4679 procedure Gather_Associations
4681 Args
: out Args_List
);
4682 -- This procedure is used to gather the arguments for a pragma that
4683 -- permits arbitrary ordering of parameters using the normal rules
4684 -- for named and positional parameters. The Names argument is a list
4685 -- of Name_Id values that corresponds to the allowed pragma argument
4686 -- association identifiers in order. The result returned in Args is
4687 -- a list of corresponding expressions that are the pragma arguments.
4688 -- Note that this is a list of expressions, not of pragma argument
4689 -- associations (Gather_Associations has completely checked all the
4690 -- optional identifiers when it returns). An entry in Args is Empty
4691 -- on return if the corresponding argument is not present.
4693 procedure GNAT_Pragma
;
4694 -- Called for all GNAT defined pragmas to check the relevant restriction
4695 -- (No_Implementation_Pragmas).
4697 function Is_Before_First_Decl
4698 (Pragma_Node
: Node_Id
;
4699 Decls
: List_Id
) return Boolean;
4700 -- Return True if Pragma_Node is before the first declarative item in
4701 -- Decls where Decls is the list of declarative items.
4703 function Is_Configuration_Pragma
return Boolean;
4704 -- Determines if the placement of the current pragma is appropriate
4705 -- for a configuration pragma.
4707 function Is_In_Context_Clause
return Boolean;
4708 -- Returns True if pragma appears within the context clause of a unit,
4709 -- and False for any other placement (does not generate any messages).
4711 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4712 -- Analyzes the argument, and determines if it is a static string
4713 -- expression, returns True if so, False if non-static or not String.
4714 -- A special case is that a string literal returns True in Ada 83 mode
4715 -- (which has no such thing as static string expressions). Note that
4716 -- the call analyzes its argument, so this cannot be used for the case
4717 -- where an identifier might not be declared.
4719 procedure Pragma_Misplaced
;
4720 pragma No_Return
(Pragma_Misplaced
);
4721 -- Issue fatal error message for misplaced pragma
4723 procedure Process_Atomic_Independent_Shared_Volatile
;
4724 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4725 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4726 -- and treated as being identical in effect to pragma Atomic.
4728 procedure Process_Compile_Time_Warning_Or_Error
;
4729 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4731 procedure Process_Convention
4732 (C
: out Convention_Id
;
4733 Ent
: out Entity_Id
);
4734 -- Common processing for Convention, Interface, Import and Export.
4735 -- Checks first two arguments of pragma, and sets the appropriate
4736 -- convention value in the specified entity or entities. On return
4737 -- C is the convention, Ent is the referenced entity.
4739 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4740 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4741 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4743 procedure Process_Extended_Import_Export_Object_Pragma
4744 (Arg_Internal
: Node_Id
;
4745 Arg_External
: Node_Id
;
4746 Arg_Size
: Node_Id
);
4747 -- Common processing for the pragmas Import/Export_Object. The three
4748 -- arguments correspond to the three named parameters of the pragmas. An
4749 -- argument is empty if the corresponding parameter is not present in
4752 procedure Process_Extended_Import_Export_Internal_Arg
4753 (Arg_Internal
: Node_Id
:= Empty
);
4754 -- Common processing for all extended Import and Export pragmas. The
4755 -- argument is the pragma parameter for the Internal argument. If
4756 -- Arg_Internal is empty or inappropriate, an error message is posted.
4757 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4758 -- set to identify the referenced entity.
4760 procedure Process_Extended_Import_Export_Subprogram_Pragma
4761 (Arg_Internal
: Node_Id
;
4762 Arg_External
: Node_Id
;
4763 Arg_Parameter_Types
: Node_Id
;
4764 Arg_Result_Type
: Node_Id
:= Empty
;
4765 Arg_Mechanism
: Node_Id
;
4766 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4767 -- Common processing for all extended Import and Export pragmas applying
4768 -- to subprograms. The caller omits any arguments that do not apply to
4769 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4770 -- only in the Import_Function and Export_Function cases). The argument
4771 -- names correspond to the allowed pragma association identifiers.
4773 procedure Process_Generic_List
;
4774 -- Common processing for Share_Generic and Inline_Generic
4776 procedure Process_Import_Or_Interface
;
4777 -- Common processing for Import or Interface
4779 procedure Process_Import_Predefined_Type
;
4780 -- Processing for completing a type with pragma Import. This is used
4781 -- to declare types that match predefined C types, especially for cases
4782 -- without corresponding Ada predefined type.
4784 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4785 -- Inline status of a subprogram, indicated as follows:
4786 -- Suppressed: inlining is suppressed for the subprogram
4787 -- Disabled: no inlining is requested for the subprogram
4788 -- Enabled: inlining is requested/required for the subprogram
4790 procedure Process_Inline
(Status
: Inline_Status
);
4791 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4792 -- indicates the inline status specified by the pragma.
4794 procedure Process_Interface_Name
4795 (Subprogram_Def
: Entity_Id
;
4799 -- Given the last two arguments of pragma Import, pragma Export, or
4800 -- pragma Interface_Name, performs validity checks and sets the
4801 -- Interface_Name field of the given subprogram entity to the
4802 -- appropriate external or link name, depending on the arguments given.
4803 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4804 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4805 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4806 -- nor Link_Arg is present, the interface name is set to the default
4807 -- from the subprogram name. In addition, the pragma itself is passed
4808 -- to analyze any expressions in the case the pragma came from an aspect
4811 procedure Process_Interrupt_Or_Attach_Handler
;
4812 -- Common processing for Interrupt and Attach_Handler pragmas
4814 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4815 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4816 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4817 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4818 -- is not set in the Restrictions case.
4820 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4821 -- Common processing for Suppress and Unsuppress. The boolean parameter
4822 -- Suppress_Case is True for the Suppress case, and False for the
4825 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4826 -- Subsidiary to the analysis of pragmas Independent[_Components].
4827 -- Record such a pragma N applied to entity E for future checks.
4829 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4830 -- This procedure sets the Is_Exported flag for the given entity,
4831 -- checking that the entity was not previously imported. Arg is
4832 -- the argument that specified the entity. A check is also made
4833 -- for exporting inappropriate entities.
4835 procedure Set_Extended_Import_Export_External_Name
4836 (Internal_Ent
: Entity_Id
;
4837 Arg_External
: Node_Id
);
4838 -- Common processing for all extended import export pragmas. The first
4839 -- argument, Internal_Ent, is the internal entity, which has already
4840 -- been checked for validity by the caller. Arg_External is from the
4841 -- Import or Export pragma, and may be null if no External parameter
4842 -- was present. If Arg_External is present and is a non-null string
4843 -- (a null string is treated as the default), then the Interface_Name
4844 -- field of Internal_Ent is set appropriately.
4846 procedure Set_Imported
(E
: Entity_Id
);
4847 -- This procedure sets the Is_Imported flag for the given entity,
4848 -- checking that it is not previously exported or imported.
4850 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4851 -- Mech is a parameter passing mechanism (see Import_Function syntax
4852 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4853 -- has the right form, and if not issues an error message. If the
4854 -- argument has the right form then the Mechanism field of Ent is
4855 -- set appropriately.
4857 procedure Set_Rational_Profile
;
4858 -- Activate the set of configuration pragmas and permissions that make
4859 -- up the Rational profile.
4861 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4862 -- Activate the set of configuration pragmas and restrictions that make
4863 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4864 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4865 -- pragma node, which is used for error messages on any constructs
4866 -- violating the profile.
4868 ---------------------
4869 -- Ada_2005_Pragma --
4870 ---------------------
4872 procedure Ada_2005_Pragma
is
4874 if Ada_Version
<= Ada_95
then
4875 Check_Restriction
(No_Implementation_Pragmas
, N
);
4877 end Ada_2005_Pragma
;
4879 ---------------------
4880 -- Ada_2012_Pragma --
4881 ---------------------
4883 procedure Ada_2012_Pragma
is
4885 if Ada_Version
<= Ada_2005
then
4886 Check_Restriction
(No_Implementation_Pragmas
, N
);
4888 end Ada_2012_Pragma
;
4890 ----------------------------
4891 -- Analyze_Depends_Global --
4892 ----------------------------
4894 procedure Analyze_Depends_Global
4895 (Spec_Id
: out Entity_Id
;
4896 Subp_Decl
: out Node_Id
;
4897 Legal
: out Boolean)
4900 -- Assume that the pragma is illegal
4907 Check_Arg_Count
(1);
4909 -- Ensure the proper placement of the pragma. Depends/Global must be
4910 -- associated with a subprogram declaration or a body that acts as a
4913 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4917 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4920 -- Generic subprogram
4922 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4925 -- Object declaration of a single concurrent type
4927 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4928 and then Is_Single_Concurrent_Object
4929 (Unique_Defining_Entity
(Subp_Decl
))
4935 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4938 -- Abstract subprogram declaration
4940 elsif Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4943 -- Subprogram body acts as spec
4945 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4946 and then No
(Corresponding_Spec
(Subp_Decl
))
4950 -- Subprogram body stub acts as spec
4952 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4953 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4957 -- Subprogram declaration
4959 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4961 -- Pragmas Global and Depends are forbidden on null procedures
4962 -- (SPARK RM 6.1.2(2)).
4964 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4965 and then Null_Present
(Specification
(Subp_Decl
))
4967 Error_Msg_N
(Fix_Error
4968 ("pragma % cannot apply to null procedure"), N
);
4974 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4981 -- If we get here, then the pragma is legal
4984 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4986 -- When the related context is an entry, the entry must belong to a
4987 -- protected unit (SPARK RM 6.1.4(6)).
4989 if Is_Entry_Declaration
(Spec_Id
)
4990 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4994 -- When the related context is an anonymous object created for a
4995 -- simple concurrent type, the type must be a task
4996 -- (SPARK RM 6.1.4(6)).
4998 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4999 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
5004 -- A pragma that applies to a Ghost entity becomes Ghost for the
5005 -- purposes of legality checks and removal of ignored Ghost code.
5007 Mark_Ghost_Pragma
(N
, Spec_Id
);
5008 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5009 end Analyze_Depends_Global
;
5011 ------------------------
5012 -- Analyze_If_Present --
5013 ------------------------
5015 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
5017 Analyze_If_Present_Internal
(N
, Id
, Included
=> False);
5018 end Analyze_If_Present
;
5020 --------------------------------
5021 -- Analyze_Pre_Post_Condition --
5022 --------------------------------
5024 procedure Analyze_Pre_Post_Condition
is
5025 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
5026 Subp_Decl
: Node_Id
;
5027 Subp_Id
: Entity_Id
;
5029 Duplicates_OK
: Boolean := False;
5030 -- Flag set when a pre/postcondition allows multiple pragmas of the
5033 In_Body_OK
: Boolean := False;
5034 -- Flag set when a pre/postcondition is allowed to appear on a body
5035 -- even though the subprogram may have a spec.
5037 Is_Pre_Post
: Boolean := False;
5038 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
5041 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
5042 -- Implement rules in AI12-0131: an overriding operation can have
5043 -- a class-wide precondition only if one of its ancestors has an
5044 -- explicit class-wide precondition.
5046 -----------------------------
5047 -- Inherits_Class_Wide_Pre --
5048 -----------------------------
5050 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
5051 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
5054 Prev
: Entity_Id
:= Overridden_Operation
(E
);
5057 -- Check ancestors on the overriding operation to examine the
5058 -- preconditions that may apply to them.
5060 while Present
(Prev
) loop
5061 Cont
:= Contract
(Prev
);
5062 if Present
(Cont
) then
5063 Prag
:= Pre_Post_Conditions
(Cont
);
5064 while Present
(Prag
) loop
5065 if Pragma_Name
(Prag
) = Name_Precondition
5066 and then Class_Present
(Prag
)
5071 Prag
:= Next_Pragma
(Prag
);
5075 -- For a type derived from a generic formal type, the operation
5076 -- inheriting the condition is a renaming, not an overriding of
5077 -- the operation of the formal. Ditto for an inherited
5078 -- operation which has no explicit contracts.
5080 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
5081 or else not Comes_From_Source
(Prev
)
5083 Prev
:= Alias
(Prev
);
5085 Prev
:= Overridden_Operation
(Prev
);
5089 -- If the controlling type of the subprogram has progenitors, an
5090 -- interface operation implemented by the current operation may
5091 -- have a class-wide precondition.
5093 if Has_Interfaces
(Typ
) then
5098 Prim_Elmt
: Elmt_Id
;
5099 Prim_List
: Elist_Id
;
5102 Collect_Interfaces
(Typ
, Ints
);
5103 Elmt
:= First_Elmt
(Ints
);
5105 -- Iterate over the primitive operations of each interface
5107 while Present
(Elmt
) loop
5108 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
5109 Prim_Elmt
:= First_Elmt
(Prim_List
);
5110 while Present
(Prim_Elmt
) loop
5111 Prim
:= Node
(Prim_Elmt
);
5112 if Chars
(Prim
) = Chars
(E
)
5113 and then Present
(Contract
(Prim
))
5114 and then Class_Present
5115 (Pre_Post_Conditions
(Contract
(Prim
)))
5120 Next_Elmt
(Prim_Elmt
);
5129 end Inherits_Class_Wide_Pre
;
5131 -- Start of processing for Analyze_Pre_Post_Condition
5134 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
5135 -- offer uniformity among the various kinds of pre/postconditions by
5136 -- rewriting the pragma identifier. This allows the retrieval of the
5137 -- original pragma name by routine Original_Aspect_Pragma_Name.
5139 if Comes_From_Source
(N
) then
5140 if Pname
in Name_Pre | Name_Pre_Class
then
5141 Is_Pre_Post
:= True;
5142 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
5143 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
5145 elsif Pname
in Name_Post | Name_Post_Class
then
5146 Is_Pre_Post
:= True;
5147 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
5148 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
5152 -- Determine the semantics with respect to duplicates and placement
5153 -- in a body. Pragmas Precondition and Postcondition were introduced
5154 -- before aspects and are not subject to the same aspect-like rules.
5156 if Pname
in Name_Precondition | Name_Postcondition
then
5157 Duplicates_OK
:= True;
5163 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
5164 -- argument without an identifier.
5167 Check_Arg_Count
(1);
5168 Check_No_Identifiers
;
5170 -- Pragmas Precondition and Postcondition have complex argument
5174 Check_At_Least_N_Arguments
(1);
5175 Check_At_Most_N_Arguments
(2);
5176 Check_Optional_Identifier
(Arg1
, Name_Check
);
5178 if Present
(Arg2
) then
5179 Check_Optional_Identifier
(Arg2
, Name_Message
);
5180 Preanalyze_Spec_Expression
5181 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5185 -- For a pragma PPC in the extended main source unit, record enabled
5187 -- ??? nothing checks that the pragma is in the main source unit
5189 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5190 Set_SCO_Pragma_Enabled
(Loc
);
5193 -- Ensure the proper placement of the pragma
5196 Find_Related_Declaration_Or_Body
5197 (N
, Do_Checks
=> not Duplicates_OK
);
5199 -- When a pre/postcondition pragma applies to an abstract subprogram,
5200 -- its original form must be an aspect with 'Class.
5202 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
5203 if not From_Aspect_Specification
(N
) then
5205 ("pragma % cannot be applied to abstract subprogram");
5207 elsif not Class_Present
(N
) then
5209 ("aspect % requires ''Class for abstract subprogram");
5212 -- Entry declaration
5214 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
5217 -- Generic subprogram declaration
5219 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
5224 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
5225 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
5229 -- Subprogram body stub
5231 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5232 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
5236 -- Subprogram declaration
5238 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
5240 -- AI05-0230: When a pre/postcondition pragma applies to a null
5241 -- procedure, its original form must be an aspect with 'Class.
5243 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
5244 and then Null_Present
(Specification
(Subp_Decl
))
5245 and then From_Aspect_Specification
(N
)
5246 and then not Class_Present
(N
)
5248 Error_Pragma
("aspect % requires ''Class for null procedure");
5251 -- Implement the legality checks mandated by AI12-0131:
5252 -- Pre'Class shall not be specified for an overriding primitive
5253 -- subprogram of a tagged type T unless the Pre'Class aspect is
5254 -- specified for the corresponding primitive subprogram of some
5258 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
5261 if Class_Present
(N
)
5262 and then Pragma_Name
(N
) = Name_Precondition
5263 and then Present
(Overridden_Operation
(E
))
5264 and then not Inherits_Class_Wide_Pre
(E
)
5267 ("illegal class-wide precondition on overriding operation",
5268 Corresponding_Aspect
(N
));
5272 -- A renaming declaration may inherit a generated pragma, its
5273 -- placement comes from expansion, not from source.
5275 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
5276 and then not Comes_From_Source
(N
)
5280 -- For Ada 2022, pre/postconditions can appear on formal subprograms
5282 elsif Nkind
(Subp_Decl
) = N_Formal_Concrete_Subprogram_Declaration
5283 and then Ada_Version
>= Ada_2022
5287 -- An access-to-subprogram type can have pre/postconditions, which
5288 -- are both analyzed when attached to the type and copied to the
5289 -- generated subprogram wrapper and analyzed there.
5291 elsif Nkind
(Subp_Decl
) = N_Full_Type_Declaration
5292 and then Nkind
(Type_Definition
(Subp_Decl
)) in
5293 N_Access_To_Subprogram_Definition
5295 if Ada_Version
< Ada_2022
then
5296 Error_Msg_Ada_2022_Feature
5297 ("pre/postcondition on access-to-subprogram", Loc
);
5301 -- Otherwise the placement of the pragma is illegal
5307 Subp_Id
:= Defining_Entity
(Subp_Decl
);
5309 -- A pragma that applies to a Ghost entity becomes Ghost for the
5310 -- purposes of legality checks and removal of ignored Ghost code.
5312 Mark_Ghost_Pragma
(N
, Subp_Id
);
5314 -- Chain the pragma on the contract for further processing by
5315 -- Analyze_Pre_Post_Condition_In_Decl_Part.
5317 if Ekind
(Subp_Id
) in Access_Subprogram_Kind
then
5318 Add_Contract_Item
(N
, Directly_Designated_Type
(Subp_Id
));
5320 Add_Contract_Item
(N
, Subp_Id
);
5323 -- Fully analyze the pragma when it appears inside an entry or
5324 -- subprogram body because it cannot benefit from forward references.
5326 if Nkind
(Subp_Decl
) in N_Entry_Body
5328 | N_Subprogram_Body_Stub
5330 -- The legality checks of pragmas Precondition and Postcondition
5331 -- are affected by the SPARK mode in effect and the volatility of
5332 -- the context. Analyze all pragmas in a specific order.
5334 Analyze_If_Present
(Pragma_SPARK_Mode
);
5335 Analyze_If_Present
(Pragma_Volatile_Function
);
5336 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
5338 end Analyze_Pre_Post_Condition
;
5340 -----------------------------------------
5341 -- Analyze_Refined_Depends_Global_Post --
5342 -----------------------------------------
5344 procedure Analyze_Refined_Depends_Global_Post
5345 (Spec_Id
: out Entity_Id
;
5346 Body_Id
: out Entity_Id
;
5347 Legal
: out Boolean)
5349 Body_Decl
: Node_Id
;
5350 Spec_Decl
: Node_Id
;
5353 -- Assume that the pragma is illegal
5360 Check_Arg_Count
(1);
5361 Check_No_Identifiers
;
5363 -- Verify the placement of the pragma and check for duplicates. The
5364 -- pragma must apply to a subprogram body [stub].
5366 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
5368 if Nkind
(Body_Decl
) not in
5369 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
5370 N_Task_Body | N_Task_Body_Stub
5375 Body_Id
:= Defining_Entity
(Body_Decl
);
5376 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
5378 -- The pragma must apply to the second declaration of a subprogram.
5379 -- In other words, the body [stub] cannot acts as a spec.
5381 if No
(Spec_Id
) then
5382 Error_Pragma
("pragma % cannot apply to a stand alone body");
5384 -- Catch the case where the subprogram body is a subunit and acts as
5385 -- the third declaration of the subprogram.
5387 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5388 Error_Pragma
("pragma % cannot apply to a subunit");
5391 -- A refined pragma can only apply to the body [stub] of a subprogram
5392 -- declared in the visible part of a package. Retrieve the context of
5393 -- the subprogram declaration.
5395 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
5397 -- When dealing with protected entries or protected subprograms, use
5398 -- the enclosing protected type as the proper context.
5400 if Ekind
(Spec_Id
) in E_Entry
5404 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
5406 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
5409 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
5411 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
5412 & "subprogram declared in a package specification"));
5415 -- If we get here, then the pragma is legal
5419 -- A pragma that applies to a Ghost entity becomes Ghost for the
5420 -- purposes of legality checks and removal of ignored Ghost code.
5422 Mark_Ghost_Pragma
(N
, Spec_Id
);
5424 if Pname
in Name_Refined_Depends | Name_Refined_Global
then
5425 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5427 end Analyze_Refined_Depends_Global_Post
;
5429 ----------------------------------
5430 -- Analyze_Unmodified_Or_Unused --
5431 ----------------------------------
5433 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
5438 Ghost_Error_Posted
: Boolean := False;
5439 -- Flag set when an error concerning the illegal mix of Ghost and
5440 -- non-Ghost variables is emitted.
5442 Ghost_Id
: Entity_Id
:= Empty
;
5443 -- The entity of the first Ghost variable encountered while
5444 -- processing the arguments of the pragma.
5448 Check_At_Least_N_Arguments
(1);
5450 -- Loop through arguments
5453 while Present
(Arg
) loop
5454 Check_No_Identifier
(Arg
);
5456 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5457 -- in fact generate reference, so that the entity will have a
5458 -- reference, which will inhibit any warnings about it not
5459 -- being referenced, and also properly show up in the ali file
5460 -- as a reference. But this reference is recorded before the
5461 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5462 -- generated for this reference.
5464 Check_Arg_Is_Local_Name
(Arg
);
5465 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5467 if Is_Entity_Name
(Arg_Expr
) then
5468 Arg_Id
:= Entity
(Arg_Expr
);
5470 -- Skip processing the argument if already flagged
5472 if Is_Assignable
(Arg_Id
)
5473 and then not Has_Pragma_Unmodified
(Arg_Id
)
5474 and then not Has_Pragma_Unused
(Arg_Id
)
5476 Set_Has_Pragma_Unmodified
(Arg_Id
);
5479 Set_Has_Pragma_Unused
(Arg_Id
);
5482 -- A pragma that applies to a Ghost entity becomes Ghost for
5483 -- the purposes of legality checks and removal of ignored
5486 Mark_Ghost_Pragma
(N
, Arg_Id
);
5488 -- Capture the entity of the first Ghost variable being
5489 -- processed for error detection purposes.
5491 if Is_Ghost_Entity
(Arg_Id
) then
5492 if No
(Ghost_Id
) then
5496 -- Otherwise the variable is non-Ghost. It is illegal to mix
5497 -- references to Ghost and non-Ghost entities
5500 elsif Present
(Ghost_Id
)
5501 and then not Ghost_Error_Posted
5503 Ghost_Error_Posted
:= True;
5505 Error_Msg_Name_1
:= Pname
;
5507 ("pragma % cannot mention ghost and non-ghost "
5510 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5511 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
5513 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5514 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
5517 -- Warn if already flagged as Unused or Unmodified
5519 elsif Has_Pragma_Unmodified
(Arg_Id
) then
5520 if Has_Pragma_Unused
(Arg_Id
) then
5522 (Fix_Error
("??pragma Unused already given for &!"),
5526 (Fix_Error
("??pragma Unmodified already given for &!"),
5530 -- Otherwise the pragma referenced an illegal entity
5534 ("pragma% can only be applied to a variable", Arg_Expr
);
5540 end Analyze_Unmodified_Or_Unused
;
5542 ------------------------------------
5543 -- Analyze_Unreferenced_Or_Unused --
5544 ------------------------------------
5546 procedure Analyze_Unreferenced_Or_Unused
5547 (Is_Unused
: Boolean := False)
5554 Ghost_Error_Posted
: Boolean := False;
5555 -- Flag set when an error concerning the illegal mix of Ghost and
5556 -- non-Ghost names is emitted.
5558 Ghost_Id
: Entity_Id
:= Empty
;
5559 -- The entity of the first Ghost name encountered while processing
5560 -- the arguments of the pragma.
5564 Check_At_Least_N_Arguments
(1);
5566 -- Check case of appearing within context clause
5568 if not Is_Unused
and then Is_In_Context_Clause
then
5570 -- The arguments must all be units mentioned in a with clause in
5571 -- the same context clause. Note that Par.Prag already checked
5572 -- that the arguments are either identifiers or selected
5576 while Present
(Arg
) loop
5577 Citem
:= First
(List_Containing
(N
));
5578 while Citem
/= N
loop
5579 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5581 if Nkind
(Citem
) = N_With_Clause
5582 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5584 Set_Has_Pragma_Unreferenced
5587 (Library_Unit
(Citem
))));
5588 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5597 ("argument of pragma% is not withed unit", Arg
);
5603 -- Case of not in list of context items
5607 while Present
(Arg
) loop
5608 Check_No_Identifier
(Arg
);
5610 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5611 -- in fact generate reference, so that the entity will have a
5612 -- reference, which will inhibit any warnings about it not
5613 -- being referenced, and also properly show up in the ali file
5614 -- as a reference. But this reference is recorded before the
5615 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5616 -- generated for this reference.
5618 Check_Arg_Is_Local_Name
(Arg
);
5619 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5621 if Is_Entity_Name
(Arg_Expr
) then
5622 Arg_Id
:= Entity
(Arg_Expr
);
5624 -- Warn if already flagged as Unused or Unreferenced and
5625 -- skip processing the argument.
5627 if Has_Pragma_Unreferenced
(Arg_Id
) then
5628 if Has_Pragma_Unused
(Arg_Id
) then
5630 (Fix_Error
("??pragma Unused already given for &!"),
5635 ("??pragma Unreferenced already given for &!"),
5639 -- Apply Unreferenced to the entity
5642 -- If the entity is overloaded, the pragma applies to the
5643 -- most recent overloading, as documented. In this case,
5644 -- name resolution does not generate a reference, so it
5645 -- must be done here explicitly.
5647 if Is_Overloaded
(Arg_Expr
) then
5648 Generate_Reference
(Arg_Id
, N
);
5651 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5654 Set_Has_Pragma_Unused
(Arg_Id
);
5657 -- A pragma that applies to a Ghost entity becomes Ghost
5658 -- for the purposes of legality checks and removal of
5659 -- ignored Ghost code.
5661 Mark_Ghost_Pragma
(N
, Arg_Id
);
5663 -- Capture the entity of the first Ghost name being
5664 -- processed for error detection purposes.
5666 if Is_Ghost_Entity
(Arg_Id
) then
5667 if No
(Ghost_Id
) then
5671 -- Otherwise the name is non-Ghost. It is illegal to mix
5672 -- references to Ghost and non-Ghost entities
5675 elsif Present
(Ghost_Id
)
5676 and then not Ghost_Error_Posted
5678 Ghost_Error_Posted
:= True;
5680 Error_Msg_Name_1
:= Pname
;
5682 ("pragma % cannot mention ghost and non-ghost "
5685 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5687 ("\& # declared as ghost", N
, Ghost_Id
);
5689 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5691 ("\& # declared as non-ghost", N
, Arg_Id
);
5699 end Analyze_Unreferenced_Or_Unused
;
5701 --------------------------
5702 -- Check_Ada_83_Warning --
5703 --------------------------
5705 procedure Check_Ada_83_Warning
is
5707 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5708 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5710 end Check_Ada_83_Warning
;
5712 ---------------------
5713 -- Check_Arg_Count --
5714 ---------------------
5716 procedure Check_Arg_Count
(Required
: Nat
) is
5718 if Arg_Count
/= Required
then
5719 Error_Pragma
("wrong number of arguments for pragma%");
5721 end Check_Arg_Count
;
5723 --------------------------------
5724 -- Check_Arg_Is_External_Name --
5725 --------------------------------
5727 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5728 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5731 if Nkind
(Argx
) = N_Identifier
then
5735 Analyze_And_Resolve
(Argx
, Standard_String
);
5737 if Is_OK_Static_Expression
(Argx
) then
5740 elsif Etype
(Argx
) = Any_Type
then
5743 -- An interesting special case, if we have a string literal and
5744 -- we are in Ada 83 mode, then we allow it even though it will
5745 -- not be flagged as static. This allows expected Ada 83 mode
5746 -- use of external names which are string literals, even though
5747 -- technically these are not static in Ada 83.
5749 elsif Ada_Version
= Ada_83
5750 and then Nkind
(Argx
) = N_String_Literal
5754 -- Here we have a real error (non-static expression)
5757 Error_Msg_Name_1
:= Pname
;
5758 Flag_Non_Static_Expr
5759 (Fix_Error
("argument for pragma% must be a identifier or "
5760 & "static string expression!"), Argx
);
5765 end Check_Arg_Is_External_Name
;
5767 -----------------------------
5768 -- Check_Arg_Is_Identifier --
5769 -----------------------------
5771 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5772 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5774 if Nkind
(Argx
) /= N_Identifier
then
5775 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5777 end Check_Arg_Is_Identifier
;
5779 ----------------------------------
5780 -- Check_Arg_Is_Integer_Literal --
5781 ----------------------------------
5783 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5784 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5786 if Nkind
(Argx
) /= N_Integer_Literal
then
5788 ("argument for pragma% must be integer literal", Argx
);
5790 end Check_Arg_Is_Integer_Literal
;
5792 -------------------------------------------
5793 -- Check_Arg_Is_Library_Level_Local_Name --
5794 -------------------------------------------
5798 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5799 -- | library_unit_NAME
5801 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5803 Check_Arg_Is_Local_Name
(Arg
);
5805 -- If it came from an aspect, we want to give the error just as if it
5806 -- came from source.
5808 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5809 and then (Comes_From_Source
(N
)
5810 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5813 ("argument for pragma% must be library level entity", Arg
);
5815 end Check_Arg_Is_Library_Level_Local_Name
;
5817 -----------------------------
5818 -- Check_Arg_Is_Local_Name --
5819 -----------------------------
5823 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5824 -- | library_unit_NAME
5826 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5827 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5830 -- If this pragma came from an aspect specification, we don't want to
5831 -- check for this error, because that would cause spurious errors, in
5832 -- case a type is frozen in a scope more nested than the type. The
5833 -- aspect itself of course can't be anywhere but on the declaration
5836 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5837 if From_Aspect_Specification
(Parent
(Arg
)) then
5841 -- Arg is the Expression of an N_Pragma_Argument_Association
5844 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5851 if Nkind
(Argx
) not in N_Direct_Name
5852 and then (Nkind
(Argx
) /= N_Attribute_Reference
5853 or else Present
(Expressions
(Argx
))
5854 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5855 and then (not Is_Entity_Name
(Argx
)
5856 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5858 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5861 -- No further check required if not an entity name
5863 if not Is_Entity_Name
(Argx
) then
5869 Ent
: constant Entity_Id
:= Entity
(Argx
);
5870 Scop
: constant Entity_Id
:= Scope
(Ent
);
5873 -- Case of a pragma applied to a compilation unit: pragma must
5874 -- occur immediately after the program unit in the compilation.
5876 if Is_Compilation_Unit
(Ent
) then
5878 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5881 -- Case of pragma placed immediately after spec
5883 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5886 -- Case of pragma placed immediately after body
5888 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5889 and then Present
(Corresponding_Body
(Decl
))
5893 (Parent
(Unit_Declaration_Node
5894 (Corresponding_Body
(Decl
))));
5896 -- All other cases are illegal
5903 -- Special restricted placement rule from 10.2.1(11.8/2)
5905 elsif Is_Generic_Formal
(Ent
)
5906 and then Prag_Id
= Pragma_Preelaborable_Initialization
5908 OK
:= List_Containing
(N
) =
5909 Generic_Formal_Declarations
5910 (Unit_Declaration_Node
(Scop
));
5912 -- If this is an aspect applied to a subprogram body, the
5913 -- pragma is inserted in its declarative part.
5915 elsif From_Aspect_Specification
(N
)
5916 and then Ent
= Current_Scope
5918 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5922 -- If the aspect is a predicate (possibly others ???) and the
5923 -- context is a record type, this is a discriminant expression
5924 -- within a type declaration, that freezes the predicated
5927 elsif From_Aspect_Specification
(N
)
5928 and then Prag_Id
= Pragma_Predicate
5929 and then Ekind
(Current_Scope
) = E_Record_Type
5930 and then Scop
= Scope
(Current_Scope
)
5934 -- Special case for postconditions wrappers
5936 elsif Ekind
(Scop
) in Subprogram_Kind
5937 and then Present
(Wrapped_Statements
(Scop
))
5938 and then Wrapped_Statements
(Scop
) = Current_Scope
5942 -- Default case, just check that the pragma occurs in the scope
5943 -- of the entity denoted by the name.
5946 OK
:= Current_Scope
= Scop
;
5951 ("pragma% argument must be in same declarative part", Arg
);
5955 end Check_Arg_Is_Local_Name
;
5957 ---------------------------------
5958 -- Check_Arg_Is_Locking_Policy --
5959 ---------------------------------
5961 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5962 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5965 Check_Arg_Is_Identifier
(Argx
);
5967 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5968 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5970 end Check_Arg_Is_Locking_Policy
;
5972 -----------------------------------------------
5973 -- Check_Arg_Is_Partition_Elaboration_Policy --
5974 -----------------------------------------------
5976 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5977 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5980 Check_Arg_Is_Identifier
(Argx
);
5982 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5984 ("& is not a valid partition elaboration policy name", Argx
);
5986 end Check_Arg_Is_Partition_Elaboration_Policy
;
5988 -------------------------
5989 -- Check_Arg_Is_One_Of --
5990 -------------------------
5992 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5993 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5996 Check_Arg_Is_Identifier
(Argx
);
5998 if Chars
(Argx
) not in N1 | N2
then
5999 Error_Msg_Name_2
:= N1
;
6000 Error_Msg_Name_3
:= N2
;
6001 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
6003 end Check_Arg_Is_One_Of
;
6005 procedure Check_Arg_Is_One_Of
6007 N1
, N2
, N3
: Name_Id
)
6009 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6012 Check_Arg_Is_Identifier
(Argx
);
6014 if Chars
(Argx
) not in N1 | N2 | N3
then
6015 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6017 end Check_Arg_Is_One_Of
;
6019 procedure Check_Arg_Is_One_Of
6021 N1
, N2
, N3
, N4
: Name_Id
)
6023 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6026 Check_Arg_Is_Identifier
(Argx
);
6028 if Chars
(Argx
) not in N1 | N2 | N3 | N4
then
6029 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6031 end Check_Arg_Is_One_Of
;
6033 procedure Check_Arg_Is_One_Of
6035 N1
, N2
, N3
, N4
, N5
: Name_Id
)
6037 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6040 Check_Arg_Is_Identifier
(Argx
);
6042 if Chars
(Argx
) not in N1 | N2 | N3 | N4 | N5
then
6043 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6045 end Check_Arg_Is_One_Of
;
6047 ---------------------------------
6048 -- Check_Arg_Is_Queuing_Policy --
6049 ---------------------------------
6051 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
6052 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6055 Check_Arg_Is_Identifier
(Argx
);
6057 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
6058 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
6060 end Check_Arg_Is_Queuing_Policy
;
6062 ---------------------------------------
6063 -- Check_Arg_Is_OK_Static_Expression --
6064 ---------------------------------------
6066 procedure Check_Arg_Is_OK_Static_Expression
6068 Typ
: Entity_Id
:= Empty
)
6071 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
6072 end Check_Arg_Is_OK_Static_Expression
;
6074 ------------------------------------------
6075 -- Check_Arg_Is_Task_Dispatching_Policy --
6076 ------------------------------------------
6078 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
6079 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6082 Check_Arg_Is_Identifier
(Argx
);
6084 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
6086 ("& is not an allowed task dispatching policy name", Argx
);
6088 end Check_Arg_Is_Task_Dispatching_Policy
;
6090 ---------------------
6091 -- Check_Arg_Order --
6092 ---------------------
6094 procedure Check_Arg_Order
(Names
: Name_List
) is
6097 Highest_So_Far
: Natural := 0;
6098 -- Highest index in Names seen do far
6102 for J
in 1 .. Arg_Count
loop
6103 if Chars
(Arg
) /= No_Name
then
6104 for K
in Names
'Range loop
6105 if Chars
(Arg
) = Names
(K
) then
6106 if K
< Highest_So_Far
then
6107 Error_Msg_Name_1
:= Pname
;
6109 ("parameters out of order for pragma%", Arg
);
6110 Error_Msg_Name_1
:= Names
(K
);
6111 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
6112 Error_Msg_N
("\% must appear before %", Arg
);
6116 Highest_So_Far
:= K
;
6124 end Check_Arg_Order
;
6126 --------------------------------
6127 -- Check_At_Least_N_Arguments --
6128 --------------------------------
6130 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
6132 if Arg_Count
< N
then
6133 Error_Pragma
("too few arguments for pragma%");
6135 end Check_At_Least_N_Arguments
;
6137 -------------------------------
6138 -- Check_At_Most_N_Arguments --
6139 -------------------------------
6141 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
6144 if Arg_Count
> N
then
6146 for J
in 1 .. N
loop
6148 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
6151 end Check_At_Most_N_Arguments
;
6153 ---------------------
6154 -- Check_Component --
6155 ---------------------
6157 procedure Check_Component
6160 In_Variant_Part
: Boolean := False)
6162 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
6163 Sindic
: constant Node_Id
:=
6164 Subtype_Indication
(Component_Definition
(Comp
));
6165 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
6168 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
6169 -- object constraint, then the component type shall be an Unchecked_
6172 if Nkind
(Sindic
) = N_Subtype_Indication
6173 and then Has_Per_Object_Constraint
(Comp_Id
)
6174 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
6177 ("component subtype subject to per-object constraint "
6178 & "must be an Unchecked_Union", Comp
);
6180 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
6181 -- the body of a generic unit, or within the body of any of its
6182 -- descendant library units, no part of the type of a component
6183 -- declared in a variant_part of the unchecked union type shall be of
6184 -- a formal private type or formal private extension declared within
6185 -- the formal part of the generic unit.
6187 elsif Ada_Version
>= Ada_2012
6188 and then In_Generic_Body
(UU_Typ
)
6189 and then In_Variant_Part
6190 and then Is_Private_Type
(Typ
)
6191 and then Is_Generic_Type
(Typ
)
6194 ("component of unchecked union cannot be of generic type", Comp
);
6196 elsif Needs_Finalization
(Typ
) then
6198 ("component of unchecked union cannot be controlled", Comp
);
6200 elsif Has_Task
(Typ
) then
6202 ("component of unchecked union cannot have tasks", Comp
);
6204 end Check_Component
;
6206 ----------------------------
6207 -- Check_Duplicate_Pragma --
6208 ----------------------------
6210 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
6211 Id
: Entity_Id
:= E
;
6215 -- Nothing to do if this pragma comes from an aspect specification,
6216 -- since we could not be duplicating a pragma, and we dealt with the
6217 -- case of duplicated aspects in Analyze_Aspect_Specifications.
6219 if From_Aspect_Specification
(N
) then
6223 -- Otherwise current pragma may duplicate previous pragma or a
6224 -- previously given aspect specification or attribute definition
6225 -- clause for the same pragma.
6227 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
6231 -- If the entity is a type, then we have to make sure that the
6232 -- ostensible duplicate is not for a parent type from which this
6236 if Nkind
(P
) = N_Pragma
then
6238 Args
: constant List_Id
:=
6239 Pragma_Argument_Associations
(P
);
6242 and then Is_Entity_Name
(Expression
(First
(Args
)))
6243 and then Is_Type
(Entity
(Expression
(First
(Args
))))
6244 and then Entity
(Expression
(First
(Args
))) /= E
6250 elsif Nkind
(P
) = N_Aspect_Specification
6251 and then Is_Type
(Entity
(P
))
6252 and then Entity
(P
) /= E
6258 -- Here we have a definite duplicate
6260 Error_Msg_Name_1
:= Pragma_Name
(N
);
6261 Error_Msg_Sloc
:= Sloc
(P
);
6263 -- For a single protected or a single task object, the error is
6264 -- issued on the original entity.
6266 if Ekind
(Id
) in E_Task_Type | E_Protected_Type
then
6267 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
6270 if Nkind
(P
) = N_Aspect_Specification
6271 or else From_Aspect_Specification
(P
)
6273 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
6275 -- If -gnatwr is set, warn in case of a duplicate pragma
6276 -- [No_]Inline which is suspicious but not an error, generate
6277 -- an error for other pragmas.
6279 if Pragma_Name
(N
) in Name_Inline | Name_No_Inline
then
6280 if Warn_On_Redundant_Constructs
then
6282 ("?r?pragma% for & duplicates pragma#", N
, Id
);
6285 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
6291 end Check_Duplicate_Pragma
;
6293 ----------------------------------
6294 -- Check_Duplicated_Export_Name --
6295 ----------------------------------
6297 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
6298 String_Val
: constant String_Id
:= Strval
(Nam
);
6301 -- We are only interested in the export case, and in the case of
6302 -- generics, it is the instance, not the template, that is the
6303 -- problem (the template will generate a warning in any case).
6305 if not Inside_A_Generic
6306 and then (Prag_Id
= Pragma_Export
6308 Prag_Id
= Pragma_Export_Procedure
6310 Prag_Id
= Pragma_Export_Valued_Procedure
6312 Prag_Id
= Pragma_Export_Function
)
6314 for J
in Externals
.First
.. Externals
.Last
loop
6315 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
6316 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
6317 Error_Msg_N
("external name duplicates name given#", Nam
);
6322 Externals
.Append
(Nam
);
6324 end Check_Duplicated_Export_Name
;
6326 ----------------------------------------
6327 -- Check_Expr_Is_OK_Static_Expression --
6328 ----------------------------------------
6330 procedure Check_Expr_Is_OK_Static_Expression
6332 Typ
: Entity_Id
:= Empty
)
6335 if Present
(Typ
) then
6336 Analyze_And_Resolve
(Expr
, Typ
);
6338 Analyze_And_Resolve
(Expr
);
6341 -- An expression cannot be considered static if its resolution failed
6342 -- or if it's erroneous. Stop the analysis of the related pragma.
6344 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
6347 elsif Is_OK_Static_Expression
(Expr
) then
6350 -- An interesting special case, if we have a string literal and we
6351 -- are in Ada 83 mode, then we allow it even though it will not be
6352 -- flagged as static. This allows the use of Ada 95 pragmas like
6353 -- Import in Ada 83 mode. They will of course be flagged with
6354 -- warnings as usual, but will not cause errors.
6356 elsif Ada_Version
= Ada_83
6357 and then Nkind
(Expr
) = N_String_Literal
6361 -- Finally, we have a real error
6364 Error_Msg_Name_1
:= Pname
;
6365 Flag_Non_Static_Expr
6366 (Fix_Error
("argument for pragma% must be a static expression!"),
6370 end Check_Expr_Is_OK_Static_Expression
;
6372 -------------------------
6373 -- Check_First_Subtype --
6374 -------------------------
6376 procedure Check_First_Subtype
(Arg
: Node_Id
) is
6377 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6378 Ent
: constant Entity_Id
:= Entity
(Argx
);
6381 if Is_First_Subtype
(Ent
) then
6384 elsif Is_Type
(Ent
) then
6386 ("pragma% cannot apply to subtype", Argx
);
6388 elsif Is_Object
(Ent
) then
6390 ("pragma% cannot apply to object, requires a type", Argx
);
6394 ("pragma% cannot apply to&, requires a type", Argx
);
6396 end Check_First_Subtype
;
6398 ----------------------
6399 -- Check_Identifier --
6400 ----------------------
6402 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6405 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6407 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
6408 Error_Msg_Name_1
:= Pname
;
6409 Error_Msg_Name_2
:= Id
;
6410 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6414 end Check_Identifier
;
6416 --------------------------------
6417 -- Check_Identifier_Is_One_Of --
6418 --------------------------------
6420 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
6423 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6425 if Chars
(Arg
) = No_Name
then
6426 Error_Msg_Name_1
:= Pname
;
6427 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
6430 elsif Chars
(Arg
) /= N1
6431 and then Chars
(Arg
) /= N2
6433 Error_Msg_Name_1
:= Pname
;
6434 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
6438 end Check_Identifier_Is_One_Of
;
6440 ---------------------------
6441 -- Check_In_Main_Program --
6442 ---------------------------
6444 procedure Check_In_Main_Program
is
6445 P
: constant Node_Id
:= Parent
(N
);
6448 -- Must be in subprogram body
6450 if Nkind
(P
) /= N_Subprogram_Body
then
6451 Error_Pragma
("% pragma allowed only in subprogram");
6453 -- Otherwise warn if obviously not main program
6455 elsif Present
(Parameter_Specifications
(Specification
(P
)))
6456 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
6458 Error_Msg_Name_1
:= Pname
;
6460 ("??pragma% is only effective in main program", N
);
6462 end Check_In_Main_Program
;
6464 ---------------------------------------
6465 -- Check_Interrupt_Or_Attach_Handler --
6466 ---------------------------------------
6468 procedure Check_Interrupt_Or_Attach_Handler
is
6469 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6470 Handler_Proc
, Proc_Scope
: Entity_Id
;
6475 if Prag_Id
= Pragma_Interrupt_Handler
then
6476 Check_Restriction
(No_Dynamic_Attachment
, N
);
6479 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
6480 Proc_Scope
:= Scope
(Handler_Proc
);
6482 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
6484 ("argument of pragma% must be protected procedure", Arg1
);
6487 -- For pragma case (as opposed to access case), check placement.
6488 -- We don't need to do that for aspects, because we have the
6489 -- check that they aspect applies an appropriate procedure.
6491 if not From_Aspect_Specification
(N
)
6492 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
6494 Error_Pragma
("pragma% must be in protected definition");
6497 if not Is_Library_Level_Entity
(Proc_Scope
) then
6499 ("argument for pragma% must be library level entity", Arg1
);
6502 -- AI05-0033: A pragma cannot appear within a generic body, because
6503 -- instance can be in a nested scope. The check that protected type
6504 -- is itself a library-level declaration is done elsewhere.
6506 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6507 -- handle code prior to AI-0033. Analysis tools typically are not
6508 -- interested in this pragma in any case, so no need to worry too
6509 -- much about its placement.
6511 if Inside_A_Generic
then
6512 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
6513 and then In_Package_Body
(Scope
(Current_Scope
))
6514 and then not Relaxed_RM_Semantics
6516 Error_Pragma
("pragma% cannot be used inside a generic");
6519 end Check_Interrupt_Or_Attach_Handler
;
6521 ---------------------------------
6522 -- Check_Loop_Pragma_Placement --
6523 ---------------------------------
6525 procedure Check_Loop_Pragma_Placement
is
6526 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
6527 -- Verify whether the current pragma is properly grouped with other
6528 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6529 -- related loop where the pragma appears.
6531 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
6532 -- Determine whether an arbitrary statement Stmt denotes pragma
6533 -- Loop_Invariant or Loop_Variant.
6535 procedure Placement_Error
(Constr
: Node_Id
);
6536 pragma No_Return
(Placement_Error
);
6537 -- Node Constr denotes the last loop restricted construct before we
6538 -- encountered an illegal relation between enclosing constructs. Emit
6539 -- an error depending on what Constr was.
6541 --------------------------------
6542 -- Check_Loop_Pragma_Grouping --
6543 --------------------------------
6545 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6546 function Check_Grouping
(L
: List_Id
) return Boolean;
6547 -- Find the first group of pragmas in list L and if successful,
6548 -- ensure that the current pragma is part of that group. The
6549 -- routine returns True once such a check is performed to
6550 -- stop the analysis.
6552 procedure Grouping_Error
(Prag
: Node_Id
);
6553 pragma No_Return
(Grouping_Error
);
6554 -- Emit an error concerning the current pragma indicating that it
6555 -- should be placed after pragma Prag.
6557 --------------------
6558 -- Check_Grouping --
6559 --------------------
6561 function Check_Grouping
(L
: List_Id
) return Boolean is
6564 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6567 -- Inspect the list of declarations or statements looking for
6568 -- the first grouping of pragmas:
6571 -- pragma Loop_Invariant ...;
6572 -- pragma Loop_Variant ...;
6574 -- pragma Loop_Variant ...; -- current pragma
6576 -- If the current pragma is not in the grouping, then it must
6577 -- either appear in a different declarative or statement list
6578 -- or the construct at (1) is separating the pragma from the
6582 while Present
(Stmt
) loop
6584 -- First pragma of the first topmost grouping has been found
6586 if Is_Loop_Pragma
(Stmt
) then
6588 -- The group and the current pragma are not in the same
6589 -- declarative or statement list.
6591 if not In_Same_List
(Stmt
, N
) then
6592 Grouping_Error
(Stmt
);
6594 -- Try to reach the current pragma from the first pragma
6595 -- of the grouping while skipping other members:
6597 -- pragma Loop_Invariant ...; -- first pragma
6598 -- pragma Loop_Variant ...; -- member
6600 -- pragma Loop_Variant ...; -- current pragma
6603 while Present
(Stmt
) loop
6604 -- The current pragma is either the first pragma
6605 -- of the group or is a member of the group.
6606 -- Stop the search as the placement is legal.
6611 -- Skip group members, but keep track of the
6612 -- last pragma in the group.
6614 elsif Is_Loop_Pragma
(Stmt
) then
6617 -- Skip Annotate pragmas, typically used to justify
6618 -- unproved loop pragmas in GNATprove.
6620 elsif Nkind
(Stmt
) = N_Pragma
6621 and then Pragma_Name
(Stmt
) = Name_Annotate
6625 -- Skip declarations and statements generated by
6626 -- the compiler during expansion. Note that some
6627 -- source statements (e.g. pragma Assert) may have
6628 -- been transformed so that they do not appear as
6629 -- coming from source anymore, so we instead look
6630 -- at their Original_Node.
6632 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6636 -- A non-pragma is separating the group from the
6637 -- current pragma, the placement is illegal.
6640 Grouping_Error
(Prag
);
6646 -- If the traversal did not reach the current pragma,
6647 -- then the list must be malformed.
6649 raise Program_Error
;
6652 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6653 -- inside a loop or a block housed inside a loop. Inspect
6654 -- the declarations and statements of the block as they may
6655 -- contain the first grouping. This case follows the one for
6656 -- loop pragmas, as block statements which originate in a
6657 -- loop pragma (and so Is_Loop_Pragma will return True on
6658 -- that block statement) should be treated in the previous
6661 elsif Nkind
(Stmt
) = N_Block_Statement
then
6662 HSS
:= Handled_Statement_Sequence
(Stmt
);
6664 if Check_Grouping
(Declarations
(Stmt
)) then
6668 if Present
(HSS
) then
6669 if Check_Grouping
(Statements
(HSS
)) then
6681 --------------------
6682 -- Grouping_Error --
6683 --------------------
6685 procedure Grouping_Error
(Prag
: Node_Id
) is
6687 Error_Msg_Sloc
:= Sloc
(Prag
);
6688 Error_Pragma
("pragma% must appear next to pragma#");
6693 -- Start of processing for Check_Loop_Pragma_Grouping
6696 -- Inspect the statements of the loop or nested blocks housed
6697 -- within to determine whether the current pragma is part of the
6698 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6700 Ignore
:= Check_Grouping
(Statements
(Loop_Stmt
));
6701 end Check_Loop_Pragma_Grouping
;
6703 --------------------
6704 -- Is_Loop_Pragma --
6705 --------------------
6707 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6708 Original_Stmt
: constant Node_Id
:= Original_Node
(Stmt
);
6711 -- Inspect the original node as Loop_Invariant and Loop_Variant
6712 -- pragmas are rewritten to null when assertions are disabled.
6714 return Nkind
(Original_Stmt
) = N_Pragma
6715 and then Pragma_Name_Unmapped
(Original_Stmt
)
6716 in Name_Loop_Invariant | Name_Loop_Variant
;
6719 ---------------------
6720 -- Placement_Error --
6721 ---------------------
6723 procedure Placement_Error
(Constr
: Node_Id
) is
6724 LA
: constant String := " with Loop_Entry";
6727 if Prag_Id
= Pragma_Assert
then
6728 Error_Msg_String
(1 .. LA
'Length) := LA
;
6729 Error_Msg_Strlen
:= LA
'Length;
6731 Error_Msg_Strlen
:= 0;
6734 if Nkind
(Constr
) = N_Pragma
then
6736 ("pragma %~ must appear immediately within the statements "
6740 ("block containing pragma %~ must appear immediately within "
6741 & "the statements of a loop", Constr
);
6743 end Placement_Error
;
6745 -- Local declarations
6750 -- Start of processing for Check_Loop_Pragma_Placement
6753 -- Check that pragma appears immediately within a loop statement,
6754 -- ignoring intervening block statements.
6758 while Present
(Stmt
) loop
6760 -- The pragma or previous block must appear immediately within the
6761 -- current block's declarative or statement part.
6763 if Nkind
(Stmt
) = N_Block_Statement
then
6764 if (No
(Declarations
(Stmt
))
6765 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6767 List_Containing
(Prev
) /=
6768 Statements
(Handled_Statement_Sequence
(Stmt
))
6770 Placement_Error
(Prev
);
6772 -- Keep inspecting the parents because we are now within a
6773 -- chain of nested blocks.
6777 Stmt
:= Parent
(Stmt
);
6780 -- The pragma or previous block must appear immediately within the
6781 -- statements of the loop.
6783 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6784 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6785 Placement_Error
(Prev
);
6788 -- Stop the traversal because we reached the innermost loop
6789 -- regardless of whether we encountered an error or not.
6793 -- Ignore a handled statement sequence. Note that this node may
6794 -- be related to a subprogram body in which case we will emit an
6795 -- error on the next iteration of the search.
6797 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6798 Stmt
:= Parent
(Stmt
);
6800 -- Any other statement breaks the chain from the pragma to the
6804 Placement_Error
(Prev
);
6808 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6809 -- grouped together with other such pragmas.
6811 if Is_Loop_Pragma
(N
) then
6813 -- The previous check should have located the related loop
6815 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6816 Check_Loop_Pragma_Grouping
(Stmt
);
6818 end Check_Loop_Pragma_Placement
;
6820 -------------------------------------------
6821 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6822 -------------------------------------------
6824 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6833 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6836 elsif Nkind
(P
) in N_Package_Specification | N_Block_Statement
then
6839 -- Note: the following tests seem a little peculiar, because
6840 -- they test for bodies, but if we were in the statement part
6841 -- of the body, we would already have hit the handled statement
6842 -- sequence, so the only way we get here is by being in the
6843 -- declarative part of the body.
6846 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6854 Error_Pragma
("pragma% is not in declarative part or package spec");
6855 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6857 -------------------------
6858 -- Check_No_Identifier --
6859 -------------------------
6861 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6863 if Nkind
(Arg
) = N_Pragma_Argument_Association
6864 and then Chars
(Arg
) /= No_Name
6866 Error_Pragma_Arg_Ident
6867 ("pragma% does not permit identifier& here", Arg
);
6869 end Check_No_Identifier
;
6871 --------------------------
6872 -- Check_No_Identifiers --
6873 --------------------------
6875 procedure Check_No_Identifiers
is
6879 for J
in 1 .. Arg_Count
loop
6880 Check_No_Identifier
(Arg_Node
);
6883 end Check_No_Identifiers
;
6885 ------------------------
6886 -- Check_No_Link_Name --
6887 ------------------------
6889 procedure Check_No_Link_Name
is
6891 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6895 if Present
(Arg4
) then
6897 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6899 end Check_No_Link_Name
;
6901 -------------------------------
6902 -- Check_Optional_Identifier --
6903 -------------------------------
6905 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6908 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6909 and then Chars
(Arg
) /= No_Name
6911 if Chars
(Arg
) /= Id
then
6912 Error_Msg_Name_1
:= Pname
;
6913 Error_Msg_Name_2
:= Id
;
6914 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6918 end Check_Optional_Identifier
;
6920 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6922 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6923 end Check_Optional_Identifier
;
6925 -------------------------------------
6926 -- Check_Static_Boolean_Expression --
6927 -------------------------------------
6929 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6931 if Present
(Expr
) then
6932 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6934 if not Is_OK_Static_Expression
(Expr
) then
6936 ("expression of pragma % must be static", Expr
);
6939 end Check_Static_Boolean_Expression
;
6941 -----------------------------
6942 -- Check_Static_Constraint --
6943 -----------------------------
6945 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6947 procedure Require_Static
(E
: Node_Id
);
6948 -- Require given expression to be static expression
6950 --------------------
6951 -- Require_Static --
6952 --------------------
6954 procedure Require_Static
(E
: Node_Id
) is
6956 if not Is_OK_Static_Expression
(E
) then
6957 Flag_Non_Static_Expr
6958 ("non-static constraint not allowed in Unchecked_Union!", E
);
6963 -- Start of processing for Check_Static_Constraint
6966 case Nkind
(Constr
) is
6967 when N_Discriminant_Association
=>
6968 Require_Static
(Expression
(Constr
));
6971 Require_Static
(Low_Bound
(Constr
));
6972 Require_Static
(High_Bound
(Constr
));
6974 when N_Attribute_Reference
=>
6975 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6976 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6978 when N_Range_Constraint
=>
6979 Check_Static_Constraint
(Range_Expression
(Constr
));
6981 when N_Index_Or_Discriminant_Constraint
=>
6985 IDC
:= First
(Constraints
(Constr
));
6986 while Present
(IDC
) loop
6987 Check_Static_Constraint
(IDC
);
6995 end Check_Static_Constraint
;
6997 --------------------------------------
6998 -- Check_Valid_Configuration_Pragma --
6999 --------------------------------------
7001 -- A configuration pragma must appear in the context clause of a
7002 -- compilation unit, and only other pragmas may precede it. Note that
7003 -- the test also allows use in a configuration pragma file.
7005 procedure Check_Valid_Configuration_Pragma
is
7007 if not Is_Configuration_Pragma
then
7008 Error_Pragma
("incorrect placement for configuration pragma%");
7010 end Check_Valid_Configuration_Pragma
;
7012 -------------------------------------
7013 -- Check_Valid_Library_Unit_Pragma --
7014 -------------------------------------
7016 procedure Check_Valid_Library_Unit_Pragma
is
7018 Parent_Node
: Node_Id
;
7019 Unit_Name
: Entity_Id
;
7020 Unit_Kind
: Node_Kind
;
7021 Unit_Node
: Node_Id
;
7022 Sindex
: Source_File_Index
;
7025 if not Is_List_Member
(N
) then
7029 Plist
:= List_Containing
(N
);
7030 Parent_Node
:= Parent
(Plist
);
7032 if Parent_Node
= Empty
then
7035 -- Case of pragma appearing after a compilation unit. In this case
7036 -- it must have an argument with the corresponding name and must
7037 -- be part of the following pragmas of its parent.
7039 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
7040 if Plist
/= Pragmas_After
(Parent_Node
) then
7042 ("pragma% misplaced, must be inside or after the "
7043 & "compilation unit");
7045 elsif Arg_Count
= 0 then
7047 ("argument required if outside compilation unit");
7050 Check_No_Identifiers
;
7051 Check_Arg_Count
(1);
7052 Unit_Node
:= Unit
(Parent
(Parent_Node
));
7053 Unit_Kind
:= Nkind
(Unit_Node
);
7055 Analyze
(Get_Pragma_Arg
(Arg1
));
7057 if Unit_Kind
= N_Generic_Subprogram_Declaration
7058 or else Unit_Kind
= N_Subprogram_Declaration
7060 Unit_Name
:= Defining_Entity
(Unit_Node
);
7062 elsif Unit_Kind
in N_Generic_Instantiation
then
7063 Unit_Name
:= Defining_Entity
(Unit_Node
);
7066 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
7069 if Chars
(Unit_Name
) /=
7070 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
7073 ("pragma% argument is not current unit name", Arg1
);
7076 if Ekind
(Unit_Name
) = E_Package
7077 and then Present
(Renamed_Entity
(Unit_Name
))
7079 Error_Pragma
("pragma% not allowed for renamed package");
7083 -- Pragma appears other than after a compilation unit
7086 -- Here we check for the generic instantiation case and also
7087 -- for the case of processing a generic formal package. We
7088 -- detect these cases by noting that the Sloc on the node
7089 -- does not belong to the current compilation unit.
7091 Sindex
:= Source_Index
(Current_Sem_Unit
);
7093 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
7094 -- We do not want to raise an exception here since this code
7095 -- is part of the bootstrap path where we cannot rely on
7096 -- exception propagation working.
7097 -- Instead the caller should check for N being rewritten as
7098 -- a null statement.
7099 -- This code triggers when compiling a-except.adb.
7101 Rewrite
(N
, Make_Null_Statement
(Loc
));
7103 -- If before first declaration, the pragma applies to the
7104 -- enclosing unit, and the name if present must be this name.
7106 elsif Is_Before_First_Decl
(N
, Plist
) then
7107 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
7108 Unit_Kind
:= Nkind
(Unit_Node
);
7110 if Unit_Node
= Standard_Package_Node
then
7112 ("pragma% misplaced, must be inside or after the "
7113 & "compilation unit");
7115 elsif Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
7117 ("pragma% misplaced, must be on library unit");
7119 elsif Unit_Kind
= N_Subprogram_Body
7120 and then not Acts_As_Spec
(Unit_Node
)
7123 ("pragma% misplaced, must be on the subprogram spec");
7125 elsif Nkind
(Parent_Node
) = N_Package_Body
then
7127 ("pragma% misplaced, must be on the package spec");
7129 elsif Nkind
(Parent_Node
) = N_Package_Specification
7130 and then Plist
= Private_Declarations
(Parent_Node
)
7133 ("pragma% misplaced, must be in the public part");
7135 elsif Nkind
(Parent_Node
) in N_Generic_Declaration
7136 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
7139 ("pragma% misplaced, must not be in formal part");
7141 elsif Arg_Count
> 0 then
7142 Analyze
(Get_Pragma_Arg
(Arg1
));
7144 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
7146 ("name in pragma% must be enclosing unit", Arg1
);
7149 -- It is legal to have no argument in this context
7155 -- Error if not before first declaration. This is because a
7156 -- library unit pragma argument must be the name of a library
7157 -- unit (RM 10.1.5(7)), but the only names permitted in this
7158 -- context are (RM 10.1.5(6)) names of subprogram declarations,
7159 -- generic subprogram declarations or generic instantiations.
7163 ("pragma% misplaced, must be before first declaration");
7167 end Check_Valid_Library_Unit_Pragma
;
7173 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
7174 Clist
: constant Node_Id
:= Component_List
(Variant
);
7178 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
7179 while Present
(Comp
) loop
7180 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
7181 Next_Non_Pragma
(Comp
);
7185 ---------------------------
7186 -- Ensure_Aggregate_Form --
7187 ---------------------------
7189 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
7190 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
7191 Expr
: constant Node_Id
:= Expression
(Arg
);
7192 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7193 Comps
: List_Id
:= No_List
;
7194 Exprs
: List_Id
:= No_List
;
7195 Nam
: Name_Id
:= No_Name
;
7196 Nam_Loc
: Source_Ptr
;
7199 -- The pragma argument is in positional form:
7201 -- pragma Depends (Nam => ...)
7205 -- Note that the Sloc of the Chars field is the Sloc of the pragma
7206 -- argument association.
7208 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
7210 Nam_Loc
:= Sloc
(Arg
);
7212 -- Remove the pragma argument name as this will be captured in the
7215 Set_Chars
(Arg
, No_Name
);
7218 -- The argument is already in aggregate form, but the presence of a
7219 -- name causes this to be interpreted as named association which in
7220 -- turn must be converted into an aggregate.
7222 -- pragma Global (In_Out => (A, B, C))
7226 -- pragma Global ((In_Out => (A, B, C)))
7228 -- aggregate aggregate
7230 if Nkind
(Expr
) = N_Aggregate
then
7231 if Nam
= No_Name
then
7235 -- Do not transform a null argument into an aggregate as N_Null has
7236 -- special meaning in formal verification pragmas.
7238 elsif Nkind
(Expr
) = N_Null
then
7242 -- Everything comes from source if the original comes from source
7244 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
7246 -- Positional argument is transformed into an aggregate with an
7247 -- Expressions list.
7249 if Nam
= No_Name
then
7250 Exprs
:= New_List
(Relocate_Node
(Expr
));
7252 -- An associative argument is transformed into an aggregate with
7253 -- Component_Associations.
7257 Make_Component_Association
(Loc
,
7258 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
7259 Expression
=> Relocate_Node
(Expr
)));
7262 Set_Expression
(Arg
,
7263 Make_Aggregate
(Loc
,
7264 Component_Associations
=> Comps
,
7265 Expressions
=> Exprs
));
7267 -- Restore Comes_From_Source default
7269 Set_Comes_From_Source_Default
(CFSD
);
7270 end Ensure_Aggregate_Form
;
7276 procedure Error_Pragma
(Msg
: String) is
7278 Error_Msg_Name_1
:= Pname
;
7279 Error_Msg_N
(Fix_Error
(Msg
), N
);
7283 ----------------------
7284 -- Error_Pragma_Arg --
7285 ----------------------
7287 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
7289 Error_Msg_Name_1
:= Pname
;
7290 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
7292 end Error_Pragma_Arg
;
7294 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
7296 Error_Msg_Name_1
:= Pname
;
7297 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
7298 Error_Pragma_Arg
(Msg2
, Arg
);
7299 end Error_Pragma_Arg
;
7301 ----------------------------
7302 -- Error_Pragma_Arg_Ident --
7303 ----------------------------
7305 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
7307 Error_Msg_Name_1
:= Pname
;
7308 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
7310 end Error_Pragma_Arg_Ident
;
7312 ----------------------
7313 -- Error_Pragma_Ref --
7314 ----------------------
7316 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
7318 Error_Msg_Name_1
:= Pname
;
7319 Error_Msg_Sloc
:= Sloc
(Ref
);
7320 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
7322 end Error_Pragma_Ref
;
7324 ------------------------
7325 -- Find_Lib_Unit_Name --
7326 ------------------------
7328 function Find_Lib_Unit_Name
return Entity_Id
is
7330 -- Return inner compilation unit entity, for case of nested
7331 -- categorization pragmas. This happens in generic unit.
7333 if Nkind
(Parent
(N
)) = N_Package_Specification
7334 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
7336 return Defining_Entity
(Parent
(N
));
7338 return Current_Scope
;
7340 end Find_Lib_Unit_Name
;
7342 ----------------------------
7343 -- Find_Program_Unit_Name --
7344 ----------------------------
7346 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
7347 Unit_Name
: Entity_Id
;
7348 Unit_Kind
: Node_Kind
;
7349 P
: constant Node_Id
:= Parent
(N
);
7352 if Nkind
(P
) = N_Compilation_Unit
then
7353 Unit_Kind
:= Nkind
(Unit
(P
));
7355 if Unit_Kind
in N_Subprogram_Declaration
7356 | N_Package_Declaration
7357 | N_Generic_Declaration
7359 Unit_Name
:= Defining_Entity
(Unit
(P
));
7361 if Chars
(Id
) = Chars
(Unit_Name
) then
7362 Set_Entity
(Id
, Unit_Name
);
7363 Set_Etype
(Id
, Etype
(Unit_Name
));
7365 Set_Etype
(Id
, Any_Type
);
7367 ("cannot find program unit referenced by pragma%");
7371 Set_Etype
(Id
, Any_Type
);
7372 Error_Pragma
("pragma% inapplicable to this unit");
7378 end Find_Program_Unit_Name
;
7380 -----------------------------------------
7381 -- Find_Unique_Parameterless_Procedure --
7382 -----------------------------------------
7384 function Find_Unique_Parameterless_Procedure
7386 Arg
: Node_Id
) return Entity_Id
7388 Proc
: Entity_Id
:= Empty
;
7391 -- Perform sanity checks on Name
7393 if not Is_Entity_Name
(Name
) then
7395 ("argument of pragma% must be entity name", Arg
);
7397 elsif not Is_Overloaded
(Name
) then
7398 Proc
:= Entity
(Name
);
7400 if Ekind
(Proc
) /= E_Procedure
7401 or else Present
(First_Formal
(Proc
))
7404 ("argument of pragma% must be parameterless procedure", Arg
);
7407 -- Otherwise, search through interpretations looking for one which
7408 -- has no parameters.
7412 Found
: Boolean := False;
7414 Index
: Interp_Index
;
7417 Get_First_Interp
(Name
, Index
, It
);
7418 while Present
(It
.Nam
) loop
7421 if Ekind
(Proc
) = E_Procedure
7422 and then No
(First_Formal
(Proc
))
7424 -- We found an interpretation, note it and continue
7425 -- looking looking to verify it is unique.
7429 Set_Entity
(Name
, Proc
);
7430 Set_Is_Overloaded
(Name
, False);
7432 -- Two procedures with the same name, log an error
7433 -- since the name is ambiguous.
7437 ("ambiguous handler name for pragma%", Arg
);
7441 Get_Next_Interp
(Index
, It
);
7445 -- Issue an error if we haven't found a suitable match for
7449 ("argument of pragma% must be parameterless procedure",
7453 Proc
:= Entity
(Name
);
7459 end Find_Unique_Parameterless_Procedure
;
7465 function Fix_Error
(Msg
: String) return String is
7466 Res
: String (Msg
'Range) := Msg
;
7467 Res_Last
: Natural := Msg
'Last;
7471 -- If we have a rewriting of another pragma, go to that pragma
7473 if Is_Rewrite_Substitution
(N
)
7474 and then Nkind
(Original_Node
(N
)) = N_Pragma
7476 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
7479 -- Case where pragma comes from an aspect specification
7481 if From_Aspect_Specification
(N
) then
7483 -- Change appearance of "pragma" in message to "aspect"
7486 while J
<= Res_Last
- 5 loop
7487 if Res
(J
.. J
+ 5) = "pragma" then
7488 Res
(J
.. J
+ 5) := "aspect";
7496 -- Change "argument of" at start of message to "entity for"
7499 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
7501 Res
(Res
'First .. Res
'First + 9) := "entity for";
7502 Res
(Res
'First + 10 .. Res_Last
- 1) :=
7503 Res
(Res
'First + 11 .. Res_Last
);
7504 Res_Last
:= Res_Last
- 1;
7507 -- Change "argument" at start of message to "entity"
7510 and then Res
(Res
'First .. Res
'First + 7) = "argument"
7512 Res
(Res
'First .. Res
'First + 5) := "entity";
7513 Res
(Res
'First + 6 .. Res_Last
- 2) :=
7514 Res
(Res
'First + 8 .. Res_Last
);
7515 Res_Last
:= Res_Last
- 2;
7518 -- Get name from corresponding aspect
7520 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
7523 -- Return possibly modified message
7525 return Res
(Res
'First .. Res_Last
);
7528 -------------------------
7529 -- Gather_Associations --
7530 -------------------------
7532 procedure Gather_Associations
7534 Args
: out Args_List
)
7539 -- Initialize all parameters to Empty
7541 for J
in Args
'Range loop
7545 -- That's all we have to do if there are no argument associations
7547 if No
(Pragma_Argument_Associations
(N
)) then
7551 -- Otherwise first deal with any positional parameters present
7553 Arg
:= First
(Pragma_Argument_Associations
(N
));
7554 for Index
in Args
'Range loop
7555 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
7556 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7560 -- Positional parameters all processed, if any left, then we
7561 -- have too many positional parameters.
7563 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
7565 ("too many positional associations for pragma%", Arg
);
7568 -- Process named parameters if any are present
7570 while Present
(Arg
) loop
7571 if Chars
(Arg
) = No_Name
then
7573 ("positional association cannot follow named association",
7577 for Index
in Names
'Range loop
7578 if Names
(Index
) = Chars
(Arg
) then
7579 if Present
(Args
(Index
)) then
7581 ("duplicate argument association for pragma%", Arg
);
7583 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7588 if Index
= Names
'Last then
7589 Error_Msg_Name_1
:= Pname
;
7590 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7592 -- Check for possible misspelling
7594 for Index1
in Names
'Range loop
7595 if Is_Bad_Spelling_Of
7596 (Chars
(Arg
), Names
(Index1
))
7598 Error_Msg_Name_1
:= Names
(Index1
);
7599 Error_Msg_N
-- CODEFIX
7600 ("\possible misspelling of%", Arg
);
7612 end Gather_Associations
;
7618 procedure GNAT_Pragma
is
7620 -- We need to check the No_Implementation_Pragmas restriction for
7621 -- the case of a pragma from source. Note that the case of aspects
7622 -- generating corresponding pragmas marks these pragmas as not being
7623 -- from source, so this test also catches that case.
7625 if Comes_From_Source
(N
) then
7626 Check_Restriction
(No_Implementation_Pragmas
, N
);
7630 --------------------------
7631 -- Is_Before_First_Decl --
7632 --------------------------
7634 function Is_Before_First_Decl
7635 (Pragma_Node
: Node_Id
;
7636 Decls
: List_Id
) return Boolean
7638 Item
: Node_Id
:= First
(Decls
);
7641 -- Only other pragmas can come before this pragma, but they might
7642 -- have been rewritten so check the original node.
7645 if No
(Item
) or else Nkind
(Original_Node
(Item
)) /= N_Pragma
then
7648 elsif Item
= Pragma_Node
then
7654 end Is_Before_First_Decl
;
7656 -----------------------------
7657 -- Is_Configuration_Pragma --
7658 -----------------------------
7660 -- A configuration pragma must appear in the context clause of a
7661 -- compilation unit, and only other pragmas may precede it. Note that
7662 -- the test below also permits use in a configuration pragma file.
7664 function Is_Configuration_Pragma
return Boolean is
7666 Par
: constant Node_Id
:= Parent
(N
);
7670 -- Don't evaluate List_Containing (N) if Parent (N) could be
7671 -- an N_Aspect_Specification node.
7673 if not Is_List_Member
(N
) then
7677 Lis
:= List_Containing
(N
);
7679 -- If no parent, then we are in the configuration pragma file,
7680 -- so the placement is definitely appropriate.
7685 -- Otherwise we must be in the context clause of a compilation unit
7686 -- and the only thing allowed before us in the context list is more
7687 -- configuration pragmas.
7689 elsif Nkind
(Par
) = N_Compilation_Unit
7690 and then Context_Items
(Par
) = Lis
7697 elsif Nkind
(Prg
) /= N_Pragma
then
7707 end Is_Configuration_Pragma
;
7709 --------------------------
7710 -- Is_In_Context_Clause --
7711 --------------------------
7713 function Is_In_Context_Clause
return Boolean is
7715 Parent_Node
: Node_Id
;
7718 if Is_List_Member
(N
) then
7719 Plist
:= List_Containing
(N
);
7720 Parent_Node
:= Parent
(Plist
);
7722 return Present
(Parent_Node
)
7723 and then Nkind
(Parent_Node
) = N_Compilation_Unit
7724 and then Context_Items
(Parent_Node
) = Plist
;
7728 end Is_In_Context_Clause
;
7730 ---------------------------------
7731 -- Is_Static_String_Expression --
7732 ---------------------------------
7734 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7735 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7736 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7739 Analyze_And_Resolve
(Argx
);
7741 -- Special case Ada 83, where the expression will never be static,
7742 -- but we will return true if we had a string literal to start with.
7744 if Ada_Version
= Ada_83
then
7747 -- Normal case, true only if we end up with a string literal that
7748 -- is marked as being the result of evaluating a static expression.
7751 return Is_OK_Static_Expression
(Argx
)
7752 and then Nkind
(Argx
) = N_String_Literal
;
7755 end Is_Static_String_Expression
;
7757 ----------------------
7758 -- Pragma_Misplaced --
7759 ----------------------
7761 procedure Pragma_Misplaced
is
7763 Error_Pragma
("incorrect placement of pragma%");
7764 end Pragma_Misplaced
;
7766 ------------------------------------------------
7767 -- Process_Atomic_Independent_Shared_Volatile --
7768 ------------------------------------------------
7770 procedure Process_Atomic_Independent_Shared_Volatile
is
7771 procedure Check_Full_Access_Only
(Ent
: Entity_Id
);
7772 -- Apply legality checks to type or object Ent subject to the
7773 -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
7775 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7776 -- Appropriately set flags on the given entity, either an array or
7777 -- record component, or an object declaration) according to the
7780 procedure Mark_Type
(Ent
: Entity_Id
);
7781 -- Appropriately set flags on the given entity, a type
7783 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7784 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7785 -- no explicit alignment was given, set alignment to unknown, since
7786 -- back end knows what the alignment requirements are for atomic and
7787 -- full access arrays. Note: this is necessary for derived types.
7789 -------------------------
7790 -- Check_Full_Access_Only --
7791 -------------------------
7793 procedure Check_Full_Access_Only
(Ent
: Entity_Id
) is
7796 Full_Access_Subcomponent
: exception;
7797 -- Exception raised if a full access subcomponent is found
7799 Generic_Type_Subcomponent
: exception;
7800 -- Exception raised if a subcomponent with generic type is found
7802 procedure Check_Subcomponents
(Typ
: Entity_Id
);
7803 -- Apply checks to subcomponents recursively
7805 -------------------------
7806 -- Check_Subcomponents --
7807 -------------------------
7809 procedure Check_Subcomponents
(Typ
: Entity_Id
) is
7813 if Is_Array_Type
(Typ
) then
7814 Comp
:= Component_Type
(Typ
);
7816 if Has_Atomic_Components
(Typ
)
7817 or else Is_Full_Access
(Comp
)
7819 raise Full_Access_Subcomponent
;
7821 elsif Is_Generic_Type
(Comp
) then
7822 raise Generic_Type_Subcomponent
;
7825 -- Recurse on the component type
7827 Check_Subcomponents
(Comp
);
7829 elsif Is_Record_Type
(Typ
) then
7830 Comp
:= First_Component_Or_Discriminant
(Typ
);
7831 while Present
(Comp
) loop
7833 if Is_Full_Access
(Comp
)
7834 or else Is_Full_Access
(Etype
(Comp
))
7836 raise Full_Access_Subcomponent
;
7838 elsif Is_Generic_Type
(Etype
(Comp
)) then
7839 raise Generic_Type_Subcomponent
;
7842 -- Recurse on the component type
7844 Check_Subcomponents
(Etype
(Comp
));
7846 Next_Component_Or_Discriminant
(Comp
);
7849 end Check_Subcomponents
;
7851 -- Start of processing for Check_Full_Access_Only
7854 -- Fetch the type in case we are dealing with an object or
7857 if Is_Type
(Ent
) then
7860 pragma Assert
(Is_Object
(Ent
)
7862 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7867 if not Is_Volatile
(Ent
) and then not Is_Volatile
(Typ
) then
7869 ("cannot have Full_Access_Only without Volatile/Atomic "
7873 -- Check all the subcomponents of the type recursively, if any
7875 Check_Subcomponents
(Typ
);
7878 when Full_Access_Subcomponent
=>
7880 ("cannot have Full_Access_Only with full access subcomponent "
7883 when Generic_Type_Subcomponent
=>
7885 ("cannot have Full_Access_Only with subcomponent of generic "
7886 & "type (RM C.6(8.2))");
7888 end Check_Full_Access_Only
;
7890 ------------------------------
7891 -- Mark_Component_Or_Object --
7892 ------------------------------
7894 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7896 if Prag_Id
= Pragma_Atomic
7897 or else Prag_Id
= Pragma_Shared
7898 or else Prag_Id
= Pragma_Volatile_Full_Access
7900 if Prag_Id
= Pragma_Volatile_Full_Access
then
7901 Set_Is_Volatile_Full_Access
(Ent
);
7903 Set_Is_Atomic
(Ent
);
7906 -- If the object declaration has an explicit initialization, a
7907 -- temporary may have to be created to hold the expression, to
7908 -- ensure that access to the object remains atomic.
7910 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7911 and then Present
(Expression
(Parent
(Ent
)))
7913 Set_Has_Delayed_Freeze
(Ent
);
7917 -- Atomic/Shared/Volatile_Full_Access imply Independent
7919 if Prag_Id
/= Pragma_Volatile
then
7920 Set_Is_Independent
(Ent
);
7922 if Prag_Id
= Pragma_Independent
then
7923 Record_Independence_Check
(N
, Ent
);
7927 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7929 if Prag_Id
/= Pragma_Independent
then
7930 Set_Is_Volatile
(Ent
);
7931 Set_Treat_As_Volatile
(Ent
);
7933 end Mark_Component_Or_Object
;
7939 procedure Mark_Type
(Ent
: Entity_Id
) is
7941 -- Attribute belongs on the base type. If the view of the type is
7942 -- currently private, it also belongs on the underlying type.
7944 -- In Ada 2022, the pragma can apply to a formal type, for which
7945 -- there may be no underlying type.
7947 if Prag_Id
= Pragma_Atomic
7948 or else Prag_Id
= Pragma_Shared
7949 or else Prag_Id
= Pragma_Volatile_Full_Access
7951 Set_Atomic_VFA
(Ent
);
7952 Set_Atomic_VFA
(Base_Type
(Ent
));
7954 if not Is_Generic_Type
(Ent
) then
7955 Set_Atomic_VFA
(Underlying_Type
(Ent
));
7959 -- Atomic/Shared/Volatile_Full_Access imply Independent
7961 if Prag_Id
/= Pragma_Volatile
then
7962 Set_Is_Independent
(Ent
);
7963 Set_Is_Independent
(Base_Type
(Ent
));
7965 if not Is_Generic_Type
(Ent
) then
7966 Set_Is_Independent
(Underlying_Type
(Ent
));
7968 if Prag_Id
= Pragma_Independent
then
7969 Record_Independence_Check
(N
, Base_Type
(Ent
));
7974 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7976 if Prag_Id
/= Pragma_Independent
then
7977 Set_Is_Volatile
(Ent
);
7978 Set_Is_Volatile
(Base_Type
(Ent
));
7980 if not Is_Generic_Type
(Ent
) then
7981 Set_Is_Volatile
(Underlying_Type
(Ent
));
7982 Set_Treat_As_Volatile
(Underlying_Type
(Ent
));
7985 Set_Treat_As_Volatile
(Ent
);
7988 -- Apply Volatile to the composite type's individual components,
7991 if Prag_Id
= Pragma_Volatile
7992 and then Is_Record_Type
(Etype
(Ent
))
7997 Comp
:= First_Component
(Ent
);
7998 while Present
(Comp
) loop
7999 Mark_Component_Or_Object
(Comp
);
8001 Next_Component
(Comp
);
8007 --------------------
8008 -- Set_Atomic_VFA --
8009 --------------------
8011 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
8013 if Prag_Id
= Pragma_Volatile_Full_Access
then
8014 Set_Is_Volatile_Full_Access
(Ent
);
8016 Set_Is_Atomic
(Ent
);
8019 if not Has_Alignment_Clause
(Ent
) then
8020 Reinit_Alignment
(Ent
);
8030 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
8033 Check_Ada_83_Warning
;
8034 Check_No_Identifiers
;
8035 Check_Arg_Count
(1);
8036 Check_Arg_Is_Local_Name
(Arg1
);
8037 E_Arg
:= Get_Pragma_Arg
(Arg1
);
8039 if Etype
(E_Arg
) = Any_Type
then
8043 E
:= Entity
(E_Arg
);
8044 Decl
:= Declaration_Node
(E
);
8046 -- A pragma that applies to a Ghost entity becomes Ghost for the
8047 -- purposes of legality checks and removal of ignored Ghost code.
8049 Mark_Ghost_Pragma
(N
, E
);
8051 -- Check duplicate before we chain ourselves
8053 Check_Duplicate_Pragma
(E
);
8055 -- Check the constraints of Full_Access_Only in Ada 2022. Note that
8056 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
8057 -- aspect subsumes the Volatile aspect and 2) nesting is supported
8058 -- for this aspect and the outermost enclosing VFA object prevails.
8060 -- Note also that we used to forbid specifying both Atomic and VFA on
8061 -- the same type or object, but the restriction has been lifted in
8062 -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
8064 if Prag_Id
= Pragma_Volatile_Full_Access
8065 and then From_Aspect_Specification
(N
)
8067 Get_Aspect_Id
(Corresponding_Aspect
(N
)) = Aspect_Full_Access_Only
8069 Check_Full_Access_Only
(E
);
8072 -- Deal with the case where the pragma/attribute is applied to a type
8075 if Rep_Item_Too_Early
(E
, N
)
8076 or else Rep_Item_Too_Late
(E
, N
)
8080 Check_First_Subtype
(Arg1
);
8085 -- Deal with the case where the pragma/attribute applies to a
8086 -- component or object declaration.
8088 elsif Nkind
(Decl
) = N_Object_Declaration
8089 or else (Nkind
(Decl
) = N_Component_Declaration
8090 and then Original_Record_Component
(E
) = E
)
8092 if Rep_Item_Too_Late
(E
, N
) then
8096 Mark_Component_Or_Object
(E
);
8098 -- In other cases give an error
8101 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
8103 end Process_Atomic_Independent_Shared_Volatile
;
8105 -------------------------------------------
8106 -- Process_Compile_Time_Warning_Or_Error --
8107 -------------------------------------------
8109 procedure Process_Compile_Time_Warning_Or_Error
is
8110 P
: Node_Id
:= Parent
(N
);
8111 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8114 Check_Arg_Count
(2);
8115 Check_No_Identifiers
;
8116 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
8117 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
8119 -- In GNATprove mode, pragma Compile_Time_Error is translated as
8120 -- a Check pragma in GNATprove mode, handled as an assumption in
8121 -- GNATprove. This is correct as the compiler will issue an error
8122 -- if the condition cannot be statically evaluated to False.
8123 -- Compile_Time_Warning are ignored, as the analyzer may not have the
8124 -- same information as the compiler (in particular regarding size of
8125 -- objects decided in gigi) so it makes no sense to issue a warning
8128 if GNATprove_Mode
then
8129 if Prag_Id
= Pragma_Compile_Time_Error
then
8133 -- Implement Compile_Time_Error by generating
8134 -- a corresponding Check pragma:
8136 -- pragma Check (name, condition);
8138 -- where name is the identifier matching the pragma name. So
8139 -- rewrite pragma in this manner and analyze the result.
8141 New_Args
:= New_List
8142 (Make_Pragma_Argument_Association
8144 Expression
=> Make_Identifier
(Loc
, Pname
)),
8145 Make_Pragma_Argument_Association
8147 Expression
=> Arg1x
));
8149 -- Rewrite as Check pragma
8153 Chars
=> Name_Check
,
8154 Pragma_Argument_Associations
=> New_Args
));
8160 Rewrite
(N
, Make_Null_Statement
(Loc
));
8166 -- If the condition is known at compile time (now), validate it now.
8167 -- Otherwise, register the expression for validation after the back
8168 -- end has been called, because it might be known at compile time
8169 -- then. For example, if the expression is "Record_Type'Size /= 32"
8170 -- it might be known after the back end has determined the size of
8171 -- Record_Type. We do not defer validation if we're inside a generic
8172 -- unit, because we will have more information in the instances, and
8173 -- this ultimately applies to the main unit itself, because it is not
8174 -- compiled by the back end when it is generic.
8176 if Compile_Time_Known_Value
(Arg1x
) then
8177 Validate_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
8180 while Present
(P
) and then Nkind
(P
) not in N_Generic_Declaration
8182 if (Nkind
(P
) = N_Subprogram_Body
and then not Acts_As_Spec
(P
))
8183 or else Nkind
(P
) = N_Package_Body
8185 P
:= Parent
(Corresponding_Spec
(P
));
8194 Nkind
(Unit
(Cunit
(Main_Unit
))) not in N_Generic_Declaration
8196 Defer_Compile_Time_Warning_Error_To_BE
(N
);
8199 end Process_Compile_Time_Warning_Or_Error
;
8201 ------------------------
8202 -- Process_Convention --
8203 ------------------------
8205 procedure Process_Convention
8206 (C
: out Convention_Id
;
8207 Ent
: out Entity_Id
)
8211 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
8212 -- Called if we have more than one Export/Import/Convention pragma.
8213 -- This is generally illegal, but we have a special case of allowing
8214 -- Import and Interface to coexist if they specify the convention in
8215 -- a consistent manner. We are allowed to do this, since Interface is
8216 -- an implementation defined pragma, and we choose to do it since we
8217 -- know Rational allows this combination. S is the entity id of the
8218 -- subprogram in question. This procedure also sets the special flag
8219 -- Import_Interface_Present in both pragmas in the case where we do
8220 -- have matching Import and Interface pragmas.
8222 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
8223 -- Set convention in entity E, and also flag that the entity has a
8224 -- convention pragma. If entity is for a private or incomplete type,
8225 -- also set convention and flag on underlying type. This procedure
8226 -- also deals with the special case of C_Pass_By_Copy convention,
8227 -- and error checks for inappropriate convention specification.
8229 -------------------------------
8230 -- Diagnose_Multiple_Pragmas --
8231 -------------------------------
8233 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
8234 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
8238 function Same_Convention
(Decl
: Node_Id
) return Boolean;
8239 -- Decl is a pragma node. This function returns True if this
8240 -- pragma has a first argument that is an identifier with a
8241 -- Chars field corresponding to the Convention_Id C.
8243 function Same_Name
(Decl
: Node_Id
) return Boolean;
8244 -- Decl is a pragma node. This function returns True if this
8245 -- pragma has a second argument that is an identifier with a
8246 -- Chars field that matches the Chars of the current subprogram.
8248 ---------------------
8249 -- Same_Convention --
8250 ---------------------
8252 function Same_Convention
(Decl
: Node_Id
) return Boolean is
8253 Arg1
: constant Node_Id
:=
8254 First
(Pragma_Argument_Associations
(Decl
));
8257 if Present
(Arg1
) then
8259 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8261 if Nkind
(Arg
) = N_Identifier
8262 and then Is_Convention_Name
(Chars
(Arg
))
8263 and then Get_Convention_Id
(Chars
(Arg
)) = C
8271 end Same_Convention
;
8277 function Same_Name
(Decl
: Node_Id
) return Boolean is
8278 Arg1
: constant Node_Id
:=
8279 First
(Pragma_Argument_Associations
(Decl
));
8287 Arg2
:= Next
(Arg1
);
8294 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
8296 if Nkind
(Arg
) = N_Identifier
8297 and then Chars
(Arg
) = Chars
(S
)
8306 -- Start of processing for Diagnose_Multiple_Pragmas
8311 -- Definitely give message if we have Convention/Export here
8313 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
8316 -- If we have an Import or Export, scan back from pragma to
8317 -- find any previous pragma applying to the same procedure.
8318 -- The scan will be terminated by the start of the list, or
8319 -- hitting the subprogram declaration. This won't allow one
8320 -- pragma to appear in the public part and one in the private
8321 -- part, but that seems very unlikely in practice.
8325 while Present
(Decl
) and then Decl
/= Pdec
loop
8327 -- Look for pragma with same name as us
8329 if Nkind
(Decl
) = N_Pragma
8330 and then Same_Name
(Decl
)
8332 -- Give error if same as our pragma or Export/Convention
8334 if Pragma_Name_Unmapped
(Decl
)
8337 | Pragma_Name_Unmapped
(N
)
8341 -- Case of Import/Interface or the other way round
8343 elsif Pragma_Name_Unmapped
(Decl
)
8344 in Name_Interface | Name_Import
8346 -- Here we know that we have Import and Interface. It
8347 -- doesn't matter which way round they are. See if
8348 -- they specify the same convention. If so, all OK,
8349 -- and set special flags to stop other messages
8351 if Same_Convention
(Decl
) then
8352 Set_Import_Interface_Present
(N
);
8353 Set_Import_Interface_Present
(Decl
);
8356 -- If different conventions, special message
8359 Error_Msg_Sloc
:= Sloc
(Decl
);
8361 ("convention differs from that given#", Arg1
);
8370 -- Give message if needed if we fall through those tests
8371 -- except on Relaxed_RM_Semantics where we let go: either this
8372 -- is a case accepted/ignored by other Ada compilers (e.g.
8373 -- a mix of Convention and Import), or another error will be
8374 -- generated later (e.g. using both Import and Export).
8376 if Err
and not Relaxed_RM_Semantics
then
8378 ("at most one Convention/Export/Import pragma is allowed",
8381 end Diagnose_Multiple_Pragmas
;
8383 --------------------------------
8384 -- Set_Convention_From_Pragma --
8385 --------------------------------
8387 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
8389 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8390 -- for an overridden dispatching operation. Technically this is
8391 -- an amendment and should only be done in Ada 2005 mode. However,
8392 -- this is clearly a mistake, since the problem that is addressed
8393 -- by this AI is that there is a clear gap in the RM.
8395 if Is_Dispatching_Operation
(E
)
8396 and then Present
(Overridden_Operation
(E
))
8397 and then C
/= Convention
(Overridden_Operation
(E
))
8400 ("cannot change convention for overridden dispatching "
8401 & "operation", Arg1
);
8403 -- Special check for convention Stdcall: a dispatching call is not
8404 -- allowed. A dispatching subprogram cannot be used to interface
8405 -- to the Win32 API, so this check actually does not impose any
8406 -- effective restriction.
8408 elsif Is_Dispatching_Operation
(E
)
8409 and then C
= Convention_Stdcall
8411 -- Note: make this unconditional so that if there is more
8412 -- than one call to which the pragma applies, we get a
8413 -- message for each call. Also don't use Error_Pragma,
8414 -- so that we get multiple messages.
8416 Error_Msg_Sloc
:= Sloc
(E
);
8418 ("dispatching subprogram# cannot use Stdcall convention!",
8419 Get_Pragma_Arg
(Arg1
));
8422 -- Set the convention
8424 Set_Convention
(E
, C
);
8425 Set_Has_Convention_Pragma
(E
);
8427 -- For the case of a record base type, also set the convention of
8428 -- any anonymous access types declared in the record which do not
8429 -- currently have a specified convention.
8430 -- Similarly for an array base type and anonymous access types
8433 if Is_Base_Type
(E
) then
8434 if Is_Record_Type
(E
) then
8439 Comp
:= First_Component
(E
);
8440 while Present
(Comp
) loop
8441 if Present
(Etype
(Comp
))
8443 Ekind
(Etype
(Comp
)) in
8444 E_Anonymous_Access_Type |
8445 E_Anonymous_Access_Subprogram_Type
8446 and then not Has_Convention_Pragma
(Comp
)
8448 Set_Convention
(Comp
, C
);
8451 Next_Component
(Comp
);
8455 elsif Is_Array_Type
(E
)
8456 and then Ekind
(Component_Type
(E
)) in
8457 E_Anonymous_Access_Type |
8458 E_Anonymous_Access_Subprogram_Type
8460 Set_Convention
(Designated_Type
(Component_Type
(E
)), C
);
8464 -- Deal with incomplete/private type case, where underlying type
8465 -- is available, so set convention of that underlying type.
8467 if Is_Incomplete_Or_Private_Type
(E
)
8468 and then Present
(Underlying_Type
(E
))
8470 Set_Convention
(Underlying_Type
(E
), C
);
8471 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
8474 -- A class-wide type should inherit the convention of the specific
8475 -- root type (although this isn't specified clearly by the RM).
8477 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
8478 Set_Convention
(Class_Wide_Type
(E
), C
);
8481 -- If the entity is a record type, then check for special case of
8482 -- C_Pass_By_Copy, which is treated the same as C except that the
8483 -- special record flag is set. This convention is only permitted
8484 -- on record types (see AI95-00131).
8486 if Cname
= Name_C_Pass_By_Copy
then
8487 if Is_Record_Type
(E
) then
8488 Set_C_Pass_By_Copy
(Base_Type
(E
));
8489 elsif Is_Incomplete_Or_Private_Type
(E
)
8490 and then Is_Record_Type
(Underlying_Type
(E
))
8492 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
8495 ("C_Pass_By_Copy convention allowed only for record type",
8500 -- If the entity is a derived boolean type, check for the special
8501 -- case of convention C, C++, or Fortran, where we consider any
8502 -- nonzero value to represent true.
8504 if Is_Discrete_Type
(E
)
8505 and then Root_Type
(Etype
(E
)) = Standard_Boolean
8511 C
= Convention_Fortran
)
8513 Set_Nonzero_Is_True
(Base_Type
(E
));
8515 end Set_Convention_From_Pragma
;
8519 Comp_Unit
: Unit_Number_Type
;
8525 -- Start of processing for Process_Convention
8528 Check_At_Least_N_Arguments
(2);
8529 Check_Optional_Identifier
(Arg1
, Name_Convention
);
8530 Check_Arg_Is_Identifier
(Arg1
);
8531 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
8533 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8534 -- tested again below to set the critical flag).
8536 if Cname
= Name_C_Pass_By_Copy
then
8539 -- Otherwise we must have something in the standard convention list
8541 elsif Is_Convention_Name
(Cname
) then
8542 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8544 -- Otherwise warn on unrecognized convention
8547 if Warn_On_Export_Import
then
8549 ("??unrecognized convention name, C assumed",
8550 Get_Pragma_Arg
(Arg1
));
8556 Check_Optional_Identifier
(Arg2
, Name_Entity
);
8557 Check_Arg_Is_Local_Name
(Arg2
);
8559 Id
:= Get_Pragma_Arg
(Arg2
);
8562 if not Is_Entity_Name
(Id
) then
8563 Error_Pragma_Arg
("entity name required", Arg2
);
8568 -- Set entity to return
8572 -- Ada_Pass_By_Copy special checking
8574 if C
= Convention_Ada_Pass_By_Copy
then
8575 if not Is_First_Subtype
(E
) then
8577 ("convention `Ada_Pass_By_Copy` only allowed for types",
8581 if Is_By_Reference_Type
(E
) then
8583 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8587 -- Ada_Pass_By_Reference special checking
8589 elsif C
= Convention_Ada_Pass_By_Reference
then
8590 if not Is_First_Subtype
(E
) then
8592 ("convention `Ada_Pass_By_Reference` only allowed for types",
8596 if Is_By_Copy_Type
(E
) then
8598 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8603 -- Go to renamed subprogram if present, since convention applies to
8604 -- the actual renamed entity, not to the renaming entity. If the
8605 -- subprogram is inherited, go to parent subprogram.
8607 if Is_Subprogram
(E
)
8608 and then Present
(Alias
(E
))
8610 if Nkind
(Parent
(Declaration_Node
(E
))) =
8611 N_Subprogram_Renaming_Declaration
8613 if Scope
(E
) /= Scope
(Alias
(E
)) then
8615 ("cannot apply pragma% to non-local entity&#", E
);
8620 elsif Nkind
(Parent
(E
)) in
8621 N_Full_Type_Declaration | N_Private_Extension_Declaration
8622 and then Scope
(E
) = Scope
(Alias
(E
))
8626 -- Return the parent subprogram the entity was inherited from
8632 -- Check that we are not applying this to a specless body. Relax this
8633 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8635 if Is_Subprogram
(E
)
8636 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8637 and then not Relaxed_RM_Semantics
8640 ("pragma% requires separate spec and must come before body");
8643 -- Check that we are not applying this to a named constant
8645 if Is_Named_Number
(E
) then
8646 Error_Msg_Name_1
:= Pname
;
8648 ("cannot apply pragma% to named constant!",
8649 Get_Pragma_Arg
(Arg2
));
8651 ("\supply appropriate type for&!", Arg2
);
8654 if Ekind
(E
) = E_Enumeration_Literal
then
8655 Error_Pragma
("enumeration literal not allowed for pragma%");
8658 -- Check for rep item appearing too early or too late
8660 if Etype
(E
) = Any_Type
8661 or else Rep_Item_Too_Early
(E
, N
)
8665 elsif Present
(Underlying_Type
(E
)) then
8666 E
:= Underlying_Type
(E
);
8669 if Rep_Item_Too_Late
(E
, N
) then
8673 if Has_Convention_Pragma
(E
) then
8674 Diagnose_Multiple_Pragmas
(E
);
8676 elsif Convention
(E
) = Convention_Protected
8677 or else Ekind
(Scope
(E
)) = E_Protected_Type
8680 ("a protected operation cannot be given a different convention",
8684 -- For Intrinsic, a subprogram is required
8686 if C
= Convention_Intrinsic
8687 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8689 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8691 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8692 if From_Aspect_Specification
(N
) then
8694 ("entity for aspect% must be a subprogram", Arg2
);
8697 ("second argument of pragma% must be a subprogram", Arg2
);
8701 -- Special checks for C_Variadic_n
8703 elsif C
in Convention_C_Variadic
then
8705 -- Several allowed cases
8707 if Is_Subprogram_Or_Generic_Subprogram
(E
) then
8710 -- An access to subprogram is also allowed
8712 elsif Is_Access_Type
(E
)
8713 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
8715 Subp
:= Designated_Type
(E
);
8717 -- Allow internal call to set convention of subprogram type
8719 elsif Ekind
(E
) = E_Subprogram_Type
then
8724 ("argument of pragma% must be subprogram or access type",
8728 -- ISO C requires a named parameter before the ellipsis, so a
8729 -- variadic C function taking 0 fixed parameter cannot exist.
8731 if C
= Convention_C_Variadic_0
then
8734 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8735 Get_Pragma_Arg
(Arg2
));
8737 -- Now check the number of parameters of the subprogram and give
8738 -- an error if it is lower than n.
8740 elsif Present
(Subp
) then
8742 Minimum
: constant Nat
:=
8743 Convention_Id
'Pos (C
) -
8744 Convention_Id
'Pos (Convention_C_Variadic_0
);
8751 Formal
:= First_Formal
(Subp
);
8752 while Present
(Formal
) loop
8754 Next_Formal
(Formal
);
8757 if Count
< Minimum
then
8758 Error_Msg_Uint_1
:= UI_From_Int
(Minimum
);
8760 ("argument of pragma% must have at least"
8761 & "^ parameters", Arg2
);
8766 -- Special checks for Stdcall
8768 elsif C
= Convention_Stdcall
then
8770 -- Several allowed cases
8772 if Is_Subprogram_Or_Generic_Subprogram
(E
)
8776 or else Ekind
(E
) = E_Variable
8778 -- A component as well. The entity does not have its Ekind
8779 -- set until the enclosing record declaration is fully
8782 or else Nkind
(Parent
(E
)) = N_Component_Declaration
8784 -- An access to subprogram is also allowed
8788 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
8790 -- Allow internal call to set convention of subprogram type
8792 or else Ekind
(E
) = E_Subprogram_Type
8798 ("argument of pragma% must be subprogram or access type",
8803 Set_Convention_From_Pragma
(E
);
8805 -- Deal with non-subprogram cases
8807 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8810 -- The pragma must apply to a first subtype, but it can also
8811 -- apply to a generic type in a generic formal part, in which
8812 -- case it will also appear in the corresponding instance.
8814 if Is_Generic_Type
(E
) or else In_Instance
then
8817 Check_First_Subtype
(Arg2
);
8820 Set_Convention_From_Pragma
(Base_Type
(E
));
8822 -- For access subprograms, we must set the convention on the
8823 -- internally generated directly designated type as well.
8825 if Ekind
(E
) = E_Access_Subprogram_Type
then
8826 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8830 -- For the subprogram case, set proper convention for all homonyms
8831 -- in same scope and the same declarative part, i.e. the same
8832 -- compilation unit.
8835 -- Treat a pragma Import as an implicit body, and pragma import
8836 -- as implicit reference (for navigation in GNAT Studio).
8838 if Prag_Id
= Pragma_Import
then
8839 Generate_Reference
(E
, Id
, 'b');
8841 -- For exported entities we restrict the generation of references
8842 -- to entities exported to foreign languages since entities
8843 -- exported to Ada do not provide further information to
8844 -- GNAT Studio and add undesired references to the output of the
8847 elsif Prag_Id
= Pragma_Export
8848 and then Convention
(E
) /= Convention_Ada
8850 Generate_Reference
(E
, Id
, 'i');
8853 -- If the pragma comes from an aspect, it only applies to the
8854 -- given entity, not its homonyms.
8856 if From_Aspect_Specification
(N
) then
8857 if C
= Convention_Intrinsic
8858 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8860 if Is_Fixed_Point_Type
(Etype
(Ent
))
8861 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8862 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8865 ("no intrinsic operator available for this fixed-point "
8868 ("\use expression functions with the desired "
8869 & "conversions made explicit", N
);
8876 -- Otherwise Loop through the homonyms of the pragma argument's
8877 -- entity, an apply convention to those in the current scope.
8879 Comp_Unit
:= Get_Source_Unit
(E
);
8884 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8886 -- Ignore entry for which convention is already set
8888 if Has_Convention_Pragma
(E1
) then
8892 if Is_Subprogram
(E1
)
8893 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8895 and then not Relaxed_RM_Semantics
8897 Set_Has_Completion
(E
); -- to prevent cascaded error
8899 ("pragma% requires separate spec and must come before "
8903 -- Do not set the pragma on inherited operations or on formal
8906 if Comes_From_Source
(E1
)
8907 and then Comp_Unit
= Get_Source_Unit
(E1
)
8908 and then not Is_Formal_Subprogram
(E1
)
8909 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8910 N_Full_Type_Declaration
8912 if Present
(Alias
(E1
))
8913 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8916 ("cannot apply pragma% to non-local entity& declared#",
8920 Set_Convention_From_Pragma
(E1
);
8922 if Prag_Id
= Pragma_Import
then
8923 Generate_Reference
(E1
, Id
, 'b');
8931 end Process_Convention
;
8933 ----------------------------------------
8934 -- Process_Disable_Enable_Atomic_Sync --
8935 ----------------------------------------
8937 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8939 Check_No_Identifiers
;
8940 Check_At_Most_N_Arguments
(1);
8942 -- Modeled internally as
8943 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8948 Pragma_Argument_Associations
=> New_List
(
8949 Make_Pragma_Argument_Association
(Loc
,
8951 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8953 if Present
(Arg1
) then
8954 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8958 end Process_Disable_Enable_Atomic_Sync
;
8960 -------------------------------------------------
8961 -- Process_Extended_Import_Export_Internal_Arg --
8962 -------------------------------------------------
8964 procedure Process_Extended_Import_Export_Internal_Arg
8965 (Arg_Internal
: Node_Id
:= Empty
)
8968 if No
(Arg_Internal
) then
8969 Error_Pragma
("Internal parameter required for pragma%");
8972 if Nkind
(Arg_Internal
) = N_Identifier
then
8975 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8976 and then (Prag_Id
= Pragma_Import_Function
8978 Prag_Id
= Pragma_Export_Function
)
8984 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8987 Check_Arg_Is_Local_Name
(Arg_Internal
);
8988 end Process_Extended_Import_Export_Internal_Arg
;
8990 --------------------------------------------------
8991 -- Process_Extended_Import_Export_Object_Pragma --
8992 --------------------------------------------------
8994 procedure Process_Extended_Import_Export_Object_Pragma
8995 (Arg_Internal
: Node_Id
;
8996 Arg_External
: Node_Id
;
9002 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
9003 Def_Id
:= Entity
(Arg_Internal
);
9005 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
9007 ("pragma% must designate an object", Arg_Internal
);
9010 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
9012 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
9015 ("previous Common/Psect_Object applies, pragma % not permitted",
9019 if Rep_Item_Too_Late
(Def_Id
, N
) then
9023 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
9025 if Present
(Arg_Size
) then
9026 Check_Arg_Is_External_Name
(Arg_Size
);
9029 -- Export_Object case
9031 if Prag_Id
= Pragma_Export_Object
then
9032 if not Is_Library_Level_Entity
(Def_Id
) then
9034 ("argument for pragma% must be library level entity",
9038 if Ekind
(Current_Scope
) = E_Generic_Package
then
9039 Error_Pragma
("pragma& cannot appear in a generic unit");
9042 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
9044 ("exported object must have compile time known size",
9048 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
9049 Error_Msg_N
("??duplicate Export_Object pragma", N
);
9051 Set_Exported
(Def_Id
, Arg_Internal
);
9054 -- Import_Object case
9057 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
9059 ("cannot use pragma% for task/protected object",
9063 if Ekind
(Def_Id
) = E_Constant
then
9065 ("cannot import a constant", Arg_Internal
);
9068 if Warn_On_Export_Import
9069 and then Has_Discriminants
(Etype
(Def_Id
))
9072 ("imported value must be initialized??", Arg_Internal
);
9075 if Warn_On_Export_Import
9076 and then Is_Access_Type
(Etype
(Def_Id
))
9079 ("cannot import object of an access type??", Arg_Internal
);
9082 if Warn_On_Export_Import
9083 and then Is_Imported
(Def_Id
)
9085 Error_Msg_N
("??duplicate Import_Object pragma", N
);
9087 -- Check for explicit initialization present. Note that an
9088 -- initialization generated by the code generator, e.g. for an
9089 -- access type, does not count here.
9091 elsif Present
(Expression
(Parent
(Def_Id
)))
9094 (Original_Node
(Expression
(Parent
(Def_Id
))))
9096 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9098 ("imported entities cannot be initialized (RM B.1(24))",
9099 "\no initialization allowed for & declared#", Arg1
);
9101 Set_Imported
(Def_Id
);
9102 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
9105 end Process_Extended_Import_Export_Object_Pragma
;
9107 ------------------------------------------------------
9108 -- Process_Extended_Import_Export_Subprogram_Pragma --
9109 ------------------------------------------------------
9111 procedure Process_Extended_Import_Export_Subprogram_Pragma
9112 (Arg_Internal
: Node_Id
;
9113 Arg_External
: Node_Id
;
9114 Arg_Parameter_Types
: Node_Id
;
9115 Arg_Result_Type
: Node_Id
:= Empty
;
9116 Arg_Mechanism
: Node_Id
;
9117 Arg_Result_Mechanism
: Node_Id
:= Empty
)
9123 Ambiguous
: Boolean;
9126 function Same_Base_Type
9128 Formal
: Entity_Id
) return Boolean;
9129 -- Determines if Ptype references the type of Formal. Note that only
9130 -- the base types need to match according to the spec. Ptype here is
9131 -- the argument from the pragma, which is either a type name, or an
9132 -- access attribute.
9134 --------------------
9135 -- Same_Base_Type --
9136 --------------------
9138 function Same_Base_Type
9140 Formal
: Entity_Id
) return Boolean
9142 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
9146 -- Case where pragma argument is typ'Access
9148 if Nkind
(Ptype
) = N_Attribute_Reference
9149 and then Attribute_Name
(Ptype
) = Name_Access
9151 Pref
:= Prefix
(Ptype
);
9154 if not Is_Entity_Name
(Pref
)
9155 or else Entity
(Pref
) = Any_Type
9160 -- We have a match if the corresponding argument is of an
9161 -- anonymous access type, and its designated type matches the
9162 -- type of the prefix of the access attribute
9164 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
9165 and then Base_Type
(Entity
(Pref
)) =
9166 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
9168 -- Case where pragma argument is a type name
9173 if not Is_Entity_Name
(Ptype
)
9174 or else Entity
(Ptype
) = Any_Type
9179 -- We have a match if the corresponding argument is of the type
9180 -- given in the pragma (comparing base types)
9182 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
9186 -- Start of processing for
9187 -- Process_Extended_Import_Export_Subprogram_Pragma
9190 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
9194 -- Loop through homonyms (overloadings) of the entity
9196 Hom_Id
:= Entity
(Arg_Internal
);
9197 while Present
(Hom_Id
) loop
9198 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9200 -- We need a subprogram in the current scope
9202 if not Is_Subprogram
(Def_Id
)
9203 or else Scope
(Def_Id
) /= Current_Scope
9210 -- Pragma cannot apply to subprogram body
9212 if Is_Subprogram
(Def_Id
)
9213 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
9217 ("pragma% requires separate spec and must come before "
9221 -- Test result type if given, note that the result type
9222 -- parameter can only be present for the function cases.
9224 if Present
(Arg_Result_Type
)
9225 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
9229 elsif Etype
(Def_Id
) /= Standard_Void_Type
9231 Pname
in Name_Export_Procedure | Name_Import_Procedure
9235 -- Test parameter types if given. Note that this parameter has
9236 -- not been analyzed (and must not be, since it is semantic
9237 -- nonsense), so we get it as the parser left it.
9239 elsif Present
(Arg_Parameter_Types
) then
9240 Check_Matching_Types
: declare
9245 Formal
:= First_Formal
(Def_Id
);
9247 if Nkind
(Arg_Parameter_Types
) = N_Null
then
9248 if Present
(Formal
) then
9252 -- A list of one type, e.g. (List) is parsed as a
9253 -- parenthesized expression.
9255 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
9256 and then Paren_Count
(Arg_Parameter_Types
) = 1
9259 or else Present
(Next_Formal
(Formal
))
9264 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
9267 -- A list of more than one type is parsed as a aggregate
9269 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
9270 and then Paren_Count
(Arg_Parameter_Types
) = 0
9272 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
9273 while Present
(Ptype
) or else Present
(Formal
) loop
9276 or else not Same_Base_Type
(Ptype
, Formal
)
9281 Next_Formal
(Formal
);
9286 -- Anything else is of the wrong form
9290 ("wrong form for Parameter_Types parameter",
9291 Arg_Parameter_Types
);
9293 end Check_Matching_Types
;
9296 -- Match is now False if the entry we found did not match
9297 -- either a supplied Parameter_Types or Result_Types argument
9303 -- Ambiguous case, the flag Ambiguous shows if we already
9304 -- detected this and output the initial messages.
9307 if not Ambiguous
then
9309 Error_Msg_Name_1
:= Pname
;
9311 ("pragma% does not uniquely identify subprogram!",
9313 Error_Msg_Sloc
:= Sloc
(Ent
);
9314 Error_Msg_N
("matching subprogram #!", N
);
9318 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9319 Error_Msg_N
("matching subprogram #!", N
);
9324 Hom_Id
:= Homonym
(Hom_Id
);
9327 -- See if we found an entry
9330 if not Ambiguous
then
9331 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
9333 ("pragma% cannot be given for generic subprogram");
9336 ("pragma% does not identify local subprogram");
9343 -- Import pragmas must be for imported entities
9345 if Prag_Id
= Pragma_Import_Function
9347 Prag_Id
= Pragma_Import_Procedure
9349 Prag_Id
= Pragma_Import_Valued_Procedure
9351 if not Is_Imported
(Ent
) then
9353 ("pragma Import or Interface must precede pragma%");
9356 -- Here we have the Export case which can set the entity as exported
9358 -- But does not do so if the specified external name is null, since
9359 -- that is taken as a signal in DEC Ada 83 (with which we want to be
9360 -- compatible) to request no external name.
9362 elsif Nkind
(Arg_External
) = N_String_Literal
9363 and then String_Length
(Strval
(Arg_External
)) = 0
9367 -- In all other cases, set entity as exported
9370 Set_Exported
(Ent
, Arg_Internal
);
9373 -- Special processing for Valued_Procedure cases
9375 if Prag_Id
= Pragma_Import_Valued_Procedure
9377 Prag_Id
= Pragma_Export_Valued_Procedure
9379 Formal
:= First_Formal
(Ent
);
9382 Error_Pragma
("at least one parameter required for pragma%");
9384 elsif Ekind
(Formal
) /= E_Out_Parameter
then
9385 Error_Pragma
("first parameter must have mode OUT for pragma%");
9388 Set_Is_Valued_Procedure
(Ent
);
9392 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
9394 -- Process Result_Mechanism argument if present. We have already
9395 -- checked that this is only allowed for the function case.
9397 if Present
(Arg_Result_Mechanism
) then
9398 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
9401 -- Process Mechanism parameter if present. Note that this parameter
9402 -- is not analyzed, and must not be analyzed since it is semantic
9403 -- nonsense, so we get it in exactly as the parser left it.
9405 if Present
(Arg_Mechanism
) then
9413 -- A single mechanism association without a formal parameter
9414 -- name is parsed as a parenthesized expression. All other
9415 -- cases are parsed as aggregates, so we rewrite the single
9416 -- parameter case as an aggregate for consistency.
9418 if Nkind
(Arg_Mechanism
) /= N_Aggregate
9419 and then Paren_Count
(Arg_Mechanism
) = 1
9421 Rewrite
(Arg_Mechanism
,
9422 Make_Aggregate
(Sloc
(Arg_Mechanism
),
9423 Expressions
=> New_List
(
9424 Relocate_Node
(Arg_Mechanism
))));
9427 -- Case of only mechanism name given, applies to all formals
9429 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
9430 Formal
:= First_Formal
(Ent
);
9431 while Present
(Formal
) loop
9432 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
9433 Next_Formal
(Formal
);
9436 -- Case of list of mechanism associations given
9439 if Null_Record_Present
(Arg_Mechanism
) then
9441 ("inappropriate form for Mechanism parameter",
9445 -- Deal with positional ones first
9447 Formal
:= First_Formal
(Ent
);
9449 if Present
(Expressions
(Arg_Mechanism
)) then
9450 Mname
:= First
(Expressions
(Arg_Mechanism
));
9451 while Present
(Mname
) loop
9454 ("too many mechanism associations", Mname
);
9457 Set_Mechanism_Value
(Formal
, Mname
);
9458 Next_Formal
(Formal
);
9463 -- Deal with named entries
9465 if Present
(Component_Associations
(Arg_Mechanism
)) then
9466 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
9467 while Present
(Massoc
) loop
9468 Choice
:= First
(Choices
(Massoc
));
9470 if Nkind
(Choice
) /= N_Identifier
9471 or else Present
(Next
(Choice
))
9474 ("incorrect form for mechanism association",
9478 Formal
:= First_Formal
(Ent
);
9482 ("parameter name & not present", Choice
);
9485 if Chars
(Choice
) = Chars
(Formal
) then
9487 (Formal
, Expression
(Massoc
));
9489 -- Set entity on identifier for proper tree
9492 Set_Entity
(Choice
, Formal
);
9497 Next_Formal
(Formal
);
9506 end Process_Extended_Import_Export_Subprogram_Pragma
;
9508 --------------------------
9509 -- Process_Generic_List --
9510 --------------------------
9512 procedure Process_Generic_List
is
9517 Check_No_Identifiers
;
9518 Check_At_Least_N_Arguments
(1);
9520 -- Check all arguments are names of generic units or instances
9523 while Present
(Arg
) loop
9524 Exp
:= Get_Pragma_Arg
(Arg
);
9527 if not Is_Entity_Name
(Exp
)
9529 (not Is_Generic_Instance
(Entity
(Exp
))
9531 not Is_Generic_Unit
(Entity
(Exp
)))
9534 ("pragma% argument must be name of generic unit/instance",
9540 end Process_Generic_List
;
9542 ------------------------------------
9543 -- Process_Import_Predefined_Type --
9544 ------------------------------------
9546 procedure Process_Import_Predefined_Type
is
9547 Loc
: constant Source_Ptr
:= Sloc
(N
);
9549 Ftyp
: Node_Id
:= Empty
;
9555 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
9557 Elmt
:= First_Elmt
(Predefined_Float_Types
);
9558 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
9562 Ftyp
:= Node
(Elmt
);
9564 if Present
(Ftyp
) then
9566 -- Don't build a derived type declaration, because predefined C
9567 -- types have no declaration anywhere, so cannot really be named.
9568 -- Instead build a full type declaration, starting with an
9569 -- appropriate type definition is built
9571 if Is_Floating_Point_Type
(Ftyp
) then
9572 Def
:= Make_Floating_Point_Definition
(Loc
,
9573 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
9574 Make_Real_Range_Specification
(Loc
,
9575 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
9576 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
9578 -- Should never have a predefined type we cannot handle
9581 raise Program_Error
;
9584 -- Build and insert a Full_Type_Declaration, which will be
9585 -- analyzed as soon as this list entry has been analyzed.
9587 Decl
:= Make_Full_Type_Declaration
(Loc
,
9588 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
9589 Type_Definition
=> Def
);
9591 Insert_After
(N
, Decl
);
9592 Mark_Rewrite_Insertion
(Decl
);
9595 Error_Pragma_Arg
("no matching type found for pragma%", Arg2
);
9597 end Process_Import_Predefined_Type
;
9599 ---------------------------------
9600 -- Process_Import_Or_Interface --
9601 ---------------------------------
9603 procedure Process_Import_Or_Interface
is
9609 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9610 -- pragma Import (Entity, "external name");
9612 if Relaxed_RM_Semantics
9613 and then Arg_Count
= 2
9614 and then Prag_Id
= Pragma_Import
9615 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
9618 Def_Id
:= Get_Pragma_Arg
(Arg1
);
9621 if not Is_Entity_Name
(Def_Id
) then
9622 Error_Pragma_Arg
("entity name required", Arg1
);
9625 Def_Id
:= Entity
(Def_Id
);
9626 Kill_Size_Check_Code
(Def_Id
);
9627 if Ekind
(Def_Id
) /= E_Constant
then
9628 Note_Possible_Modification
9629 (Get_Pragma_Arg
(Arg1
), Sure
=> False);
9633 Process_Convention
(C
, Def_Id
);
9635 -- A pragma that applies to a Ghost entity becomes Ghost for the
9636 -- purposes of legality checks and removal of ignored Ghost code.
9638 Mark_Ghost_Pragma
(N
, Def_Id
);
9639 Kill_Size_Check_Code
(Def_Id
);
9640 if Ekind
(Def_Id
) /= E_Constant
then
9641 Note_Possible_Modification
9642 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
9646 -- Various error checks
9648 if Ekind
(Def_Id
) in E_Variable | E_Constant
then
9650 -- We do not permit Import to apply to a renaming declaration
9652 if Present
(Renamed_Object
(Def_Id
)) then
9654 ("pragma% not allowed for object renaming", Arg2
);
9656 -- User initialization is not allowed for imported object, but
9657 -- the object declaration may contain a default initialization,
9658 -- that will be discarded. Note that an explicit initialization
9659 -- only counts if it comes from source, otherwise it is simply
9660 -- the code generator making an implicit initialization explicit.
9662 elsif Present
(Expression
(Parent
(Def_Id
)))
9663 and then Comes_From_Source
9664 (Original_Node
(Expression
(Parent
(Def_Id
))))
9666 -- Set imported flag to prevent cascaded errors
9668 Set_Is_Imported
(Def_Id
);
9670 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9672 ("no initialization allowed for declaration of& #",
9673 "\imported entities cannot be initialized (RM B.1(24))",
9677 -- If the pragma comes from an aspect specification the
9678 -- Is_Imported flag has already been set.
9680 if not From_Aspect_Specification
(N
) then
9681 Set_Imported
(Def_Id
);
9684 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9686 -- Note that we do not set Is_Public here. That's because we
9687 -- only want to set it if there is no address clause, and we
9688 -- don't know that yet, so we delay that processing till
9691 -- pragma Import completes deferred constants
9693 if Ekind
(Def_Id
) = E_Constant
then
9694 Set_Has_Completion
(Def_Id
);
9697 -- It is not possible to import a constant of an unconstrained
9698 -- array type (e.g. string) because there is no simple way to
9699 -- write a meaningful subtype for it.
9701 if Is_Array_Type
(Etype
(Def_Id
))
9702 and then not Is_Constrained
(Etype
(Def_Id
))
9705 ("imported constant& must have a constrained subtype",
9710 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9712 -- If the name is overloaded, pragma applies to all of the denoted
9713 -- entities in the same declarative part, unless the pragma comes
9714 -- from an aspect specification or was generated by the compiler
9715 -- (such as for pragma Provide_Shift_Operators).
9718 while Present
(Hom_Id
) loop
9720 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9722 -- Ignore inherited subprograms because the pragma will apply
9723 -- to the parent operation, which is the one called.
9725 if Is_Overloadable
(Def_Id
)
9726 and then Present
(Alias
(Def_Id
))
9730 -- If it is not a subprogram, it must be in an outer scope and
9731 -- pragma does not apply.
9733 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9736 -- The pragma does not apply to primitives of interfaces
9738 elsif Is_Dispatching_Operation
(Def_Id
)
9739 and then Present
(Find_Dispatching_Type
(Def_Id
))
9740 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9744 -- Verify that the homonym is in the same declarative part (not
9745 -- just the same scope). If the pragma comes from an aspect
9746 -- specification we know that it is part of the declaration.
9748 elsif (No
(Unit_Declaration_Node
(Def_Id
))
9749 or else Parent
(Unit_Declaration_Node
(Def_Id
)) /=
9751 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9752 and then not From_Aspect_Specification
(N
)
9757 -- If the pragma comes from an aspect specification the
9758 -- Is_Imported flag has already been set.
9760 if not From_Aspect_Specification
(N
) then
9761 Set_Imported
(Def_Id
);
9764 -- Reject an Import applied to an abstract subprogram
9766 if Is_Subprogram
(Def_Id
)
9767 and then Is_Abstract_Subprogram
(Def_Id
)
9769 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9771 ("cannot import abstract subprogram& declared#",
9775 -- Special processing for Convention_Intrinsic
9777 if C
= Convention_Intrinsic
then
9779 -- Link_Name argument not allowed for intrinsic
9783 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9785 -- If no external name is present, then check that this
9786 -- is a valid intrinsic subprogram. If an external name
9787 -- is present, then this is handled by the back end.
9790 Check_Intrinsic_Subprogram
9791 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9795 -- Verify that the subprogram does not have a completion
9796 -- through a renaming declaration. For other completions the
9797 -- pragma appears as a too late representation.
9800 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9804 and then Nkind
(Decl
) = N_Subprogram_Declaration
9805 and then Present
(Corresponding_Body
(Decl
))
9806 and then Nkind
(Unit_Declaration_Node
9807 (Corresponding_Body
(Decl
))) =
9808 N_Subprogram_Renaming_Declaration
9810 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9812 ("cannot import&, renaming already provided for "
9813 & "declaration #", N
, Def_Id
);
9817 -- If the pragma comes from an aspect specification, there
9818 -- must be an Import aspect specified as well. In the rare
9819 -- case where Import is set to False, the subprogram needs
9820 -- to have a local completion.
9823 Imp_Aspect
: constant Node_Id
:=
9824 Find_Aspect
(Def_Id
, Aspect_Import
);
9828 if Present
(Imp_Aspect
)
9829 and then Present
(Expression
(Imp_Aspect
))
9831 Expr
:= Expression
(Imp_Aspect
);
9832 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9834 if Is_Entity_Name
(Expr
)
9835 and then Entity
(Expr
) = Standard_True
9837 Set_Has_Completion
(Def_Id
);
9840 -- If there is no expression, the default is True, as for
9841 -- all boolean aspects. Same for the older pragma.
9844 Set_Has_Completion
(Def_Id
);
9848 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9851 if Is_Compilation_Unit
(Hom_Id
) then
9853 -- Its possible homonyms are not affected by the pragma.
9854 -- Such homonyms might be present in the context of other
9855 -- units being compiled.
9859 elsif From_Aspect_Specification
(N
) then
9862 -- If the pragma was created by the compiler, then we don't
9863 -- want it to apply to other homonyms. This kind of case can
9864 -- occur when using pragma Provide_Shift_Operators, which
9865 -- generates implicit shift and rotate operators with Import
9866 -- pragmas that might apply to earlier explicit or implicit
9867 -- declarations marked with Import (for example, coming from
9868 -- an earlier pragma Provide_Shift_Operators for another type),
9869 -- and we don't generally want other homonyms being treated
9870 -- as imported or the pragma flagged as an illegal duplicate.
9872 elsif not Comes_From_Source
(N
) then
9876 Hom_Id
:= Homonym
(Hom_Id
);
9880 -- Import a CPP class
9882 elsif C
= Convention_CPP
9883 and then (Is_Record_Type
(Def_Id
)
9884 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9886 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9887 if Present
(Full_View
(Def_Id
)) then
9888 Def_Id
:= Full_View
(Def_Id
);
9892 ("cannot import 'C'P'P type before full declaration seen",
9893 Get_Pragma_Arg
(Arg2
));
9895 -- Although we have reported the error we decorate it as
9896 -- CPP_Class to avoid reporting spurious errors
9898 Set_Is_CPP_Class
(Def_Id
);
9903 -- Types treated as CPP classes must be declared limited (note:
9904 -- this used to be a warning but there is no real benefit to it
9905 -- since we did effectively intend to treat the type as limited
9908 if not Is_Limited_Type
(Def_Id
) then
9910 ("imported 'C'P'P type must be limited",
9911 Get_Pragma_Arg
(Arg2
));
9914 if Etype
(Def_Id
) /= Def_Id
9915 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9917 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9920 Set_Is_CPP_Class
(Def_Id
);
9922 -- Imported CPP types must not have discriminants (because C++
9923 -- classes do not have discriminants).
9925 if Has_Discriminants
(Def_Id
) then
9927 ("imported 'C'P'P type cannot have discriminants",
9928 First
(Discriminant_Specifications
9929 (Declaration_Node
(Def_Id
))));
9932 -- Check that components of imported CPP types do not have default
9933 -- expressions. For private types this check is performed when the
9934 -- full view is analyzed (see Process_Full_View).
9936 if not Is_Private_Type
(Def_Id
) then
9937 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9940 -- Import a CPP exception
9942 elsif C
= Convention_CPP
9943 and then Ekind
(Def_Id
) = E_Exception
9947 ("'External_'Name arguments is required for 'Cpp exception",
9950 -- As only a string is allowed, Check_Arg_Is_External_Name
9953 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9956 if Present
(Arg4
) then
9958 ("Link_Name argument not allowed for imported Cpp exception",
9962 -- Do not call Set_Interface_Name as the name of the exception
9963 -- shouldn't be modified (and in particular it shouldn't be
9964 -- the External_Name). For exceptions, the External_Name is the
9965 -- name of the RTTI structure.
9967 -- ??? Emit an error if pragma Import/Export_Exception is present
9969 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9971 Check_Arg_Count
(3);
9972 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9974 Process_Import_Predefined_Type
;
9976 -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada
9977 -- compilers may accept more cases, e.g. JGNAT allowed importing
9980 elsif not Relaxed_RM_Semantics
then
9981 if From_Aspect_Specification
(N
) then
9983 ("entity for aspect% must be object, subprogram "
9984 & "or incomplete type",
9988 ("second argument of pragma% must be object, subprogram "
9989 & "or incomplete type",
9994 -- If this pragma applies to a compilation unit, then the unit, which
9995 -- is a subprogram, does not require (or allow) a body. We also do
9996 -- not need to elaborate imported procedures.
9998 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
10000 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
10002 Set_Body_Required
(Cunit
, False);
10005 end Process_Import_Or_Interface
;
10007 --------------------
10008 -- Process_Inline --
10009 --------------------
10011 procedure Process_Inline
(Status
: Inline_Status
) is
10018 Ghost_Error_Posted
: Boolean := False;
10019 -- Flag set when an error concerning the illegal mix of Ghost and
10020 -- non-Ghost subprograms is emitted.
10022 Ghost_Id
: Entity_Id
:= Empty
;
10023 -- The entity of the first Ghost subprogram encountered while
10024 -- processing the arguments of the pragma.
10026 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
10027 -- Verify the placement of pragma Inline_Always with respect to the
10028 -- initial declaration of subprogram Spec_Id.
10030 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
10031 -- Returns True if it can be determined at this stage that inlining
10032 -- is not possible, for example if the body is available and contains
10033 -- exception handlers, we prevent inlining, since otherwise we can
10034 -- get undefined symbols at link time. This function also emits a
10035 -- warning if the pragma appears too late.
10037 -- ??? is business with link symbols still valid, or does it relate
10038 -- to front end ZCX which is being phased out ???
10040 procedure Make_Inline
(Subp
: Entity_Id
);
10041 -- Subp is the defining unit name of the subprogram declaration. If
10042 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
10043 -- the corresponding body, if there is one present.
10045 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
10046 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
10047 -- Also set or clear Is_Inlined flag on Subp depending on Status.
10049 -----------------------------------
10050 -- Check_Inline_Always_Placement --
10051 -----------------------------------
10053 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
10054 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
10056 function Compilation_Unit_OK
return Boolean;
10057 pragma Inline
(Compilation_Unit_OK
);
10058 -- Determine whether pragma Inline_Always applies to a compatible
10059 -- compilation unit denoted by Spec_Id.
10061 function Declarative_List_OK
return Boolean;
10062 pragma Inline
(Declarative_List_OK
);
10063 -- Determine whether the initial declaration of subprogram Spec_Id
10064 -- and the pragma appear in compatible declarative lists.
10066 function Subprogram_Body_OK
return Boolean;
10067 pragma Inline
(Subprogram_Body_OK
);
10068 -- Determine whether pragma Inline_Always applies to a compatible
10069 -- subprogram body denoted by Spec_Id.
10071 -------------------------
10072 -- Compilation_Unit_OK --
10073 -------------------------
10075 function Compilation_Unit_OK
return Boolean is
10076 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
10079 -- The pragma appears after the initial declaration of a
10080 -- compilation unit.
10082 -- procedure Comp_Unit;
10083 -- pragma Inline_Always (Comp_Unit);
10085 -- Note that for compatibility reasons, the following case is
10088 -- procedure Stand_Alone_Body_Comp_Unit is
10090 -- end Stand_Alone_Body_Comp_Unit;
10091 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
10094 Nkind
(Comp_Unit
) = N_Compilation_Unit
10095 and then Present
(Aux_Decls_Node
(Comp_Unit
))
10096 and then Is_List_Member
(N
)
10097 and then List_Containing
(N
) =
10098 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
10099 end Compilation_Unit_OK
;
10101 -------------------------
10102 -- Declarative_List_OK --
10103 -------------------------
10105 function Declarative_List_OK
return Boolean is
10106 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
10108 Init_Decl
: Node_Id
;
10109 Init_List
: List_Id
;
10110 Prag_List
: List_Id
;
10113 -- Determine the proper initial declaration. In general this is
10114 -- the declaration node of the subprogram except when the input
10115 -- denotes a generic instantiation.
10117 -- procedure Inst is new Gen;
10118 -- pragma Inline_Always (Inst);
10120 -- In this case the original subprogram is moved inside an
10121 -- anonymous package while pragma Inline_Always remains at the
10122 -- level of the anonymous package. Use the declaration of the
10123 -- package because it reflects the placement of the original
10126 -- package Anon_Pack is
10127 -- procedure Inst is ... end Inst; -- original
10130 -- procedure Inst renames Anon_Pack.Inst;
10131 -- pragma Inline_Always (Inst);
10133 if Is_Generic_Instance
(Spec_Id
) then
10134 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
10135 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
10137 Init_Decl
:= Spec_Decl
;
10140 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
10141 Init_List
:= List_Containing
(Init_Decl
);
10142 Prag_List
:= List_Containing
(N
);
10144 -- The pragma and then initial declaration appear within the
10145 -- same declarative list.
10147 if Init_List
= Prag_List
then
10150 -- A special case of the above is when both the pragma and
10151 -- the initial declaration appear in different lists of a
10152 -- package spec, protected definition, or a task definition.
10157 -- pragma Inline_Always (Proc);
10160 elsif Nkind
(Context
) in N_Package_Specification
10161 | N_Protected_Definition
10162 | N_Task_Definition
10163 and then Init_List
= Visible_Declarations
(Context
)
10164 and then Prag_List
= Private_Declarations
(Context
)
10171 end Declarative_List_OK
;
10173 ------------------------
10174 -- Subprogram_Body_OK --
10175 ------------------------
10177 function Subprogram_Body_OK
return Boolean is
10178 Body_Decl
: Node_Id
;
10181 -- The pragma appears within the declarative list of a stand-
10182 -- alone subprogram body.
10184 -- procedure Stand_Alone_Body is
10185 -- pragma Inline_Always (Stand_Alone_Body);
10188 -- end Stand_Alone_Body;
10190 -- The compiler creates a dummy spec in this case, however the
10191 -- pragma remains within the declarative list of the body.
10193 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
10194 and then not Comes_From_Source
(Spec_Decl
)
10195 and then Present
(Corresponding_Body
(Spec_Decl
))
10198 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
10200 if Present
(Declarations
(Body_Decl
))
10201 and then Is_List_Member
(N
)
10202 and then List_Containing
(N
) = Declarations
(Body_Decl
)
10209 end Subprogram_Body_OK
;
10211 -- Start of processing for Check_Inline_Always_Placement
10214 -- This check is relevant only for pragma Inline_Always
10216 if Pname
/= Name_Inline_Always
then
10219 -- Nothing to do when the pragma is internally generated on the
10220 -- assumption that it is properly placed.
10222 elsif not Comes_From_Source
(N
) then
10225 -- Nothing to do for internally generated subprograms that act
10226 -- as accidental homonyms of a source subprogram being inlined.
10228 elsif not Comes_From_Source
(Spec_Id
) then
10231 -- Nothing to do for generic formal subprograms that act as
10232 -- homonyms of another source subprogram being inlined.
10234 elsif Is_Formal_Subprogram
(Spec_Id
) then
10237 elsif Compilation_Unit_OK
10238 or else Declarative_List_OK
10239 or else Subprogram_Body_OK
10244 -- At this point it is known that the pragma applies to or appears
10245 -- within a completing body, a completing stub, or a subunit.
10247 Error_Msg_Name_1
:= Pname
;
10248 Error_Msg_Name_2
:= Chars
(Spec_Id
);
10249 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
10252 ("pragma % must appear on initial declaration of subprogram "
10253 & "% defined #", N
);
10254 end Check_Inline_Always_Placement
;
10256 ---------------------------
10257 -- Inlining_Not_Possible --
10258 ---------------------------
10260 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
10261 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
10265 if Nkind
(Decl
) = N_Subprogram_Body
then
10266 Stats
:= Handled_Statement_Sequence
(Decl
);
10267 return Present
(Exception_Handlers
(Stats
))
10268 or else Present
(At_End_Proc
(Stats
));
10270 elsif Nkind
(Decl
) = N_Subprogram_Declaration
10271 and then Present
(Corresponding_Body
(Decl
))
10273 if Analyzed
(Corresponding_Body
(Decl
)) then
10274 Error_Msg_N
("pragma appears too late, ignored??", N
);
10277 -- If the subprogram is a renaming as body, the body is just a
10278 -- call to the renamed subprogram, and inlining is trivially
10282 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
10283 N_Subprogram_Renaming_Declaration
10289 Handled_Statement_Sequence
10290 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
10293 Present
(Exception_Handlers
(Stats
))
10294 or else Present
(At_End_Proc
(Stats
));
10298 -- If body is not available, assume the best, the check is
10299 -- performed again when compiling enclosing package bodies.
10303 end Inlining_Not_Possible
;
10309 procedure Make_Inline
(Subp
: Entity_Id
) is
10310 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
10311 Inner_Subp
: Entity_Id
:= Subp
;
10314 -- Ignore if bad type, avoid cascaded error
10316 if Etype
(Subp
) = Any_Type
then
10320 -- If inlining is not possible, for now do not treat as an error
10322 elsif Status
/= Suppressed
10323 and then Front_End_Inlining
10324 and then Inlining_Not_Possible
(Subp
)
10329 -- Here we have a candidate for inlining, but we must exclude
10330 -- derived operations. Otherwise we would end up trying to inline
10331 -- a phantom declaration, and the result would be to drag in a
10332 -- body which has no direct inlining associated with it. That
10333 -- would not only be inefficient but would also result in the
10334 -- backend doing cross-unit inlining in cases where it was
10335 -- definitely inappropriate to do so.
10337 -- However, a simple Comes_From_Source test is insufficient, since
10338 -- we do want to allow inlining of generic instances which also do
10339 -- not come from source. We also need to recognize specs generated
10340 -- by the front-end for bodies that carry the pragma. Finally,
10341 -- predefined operators do not come from source but are not
10342 -- inlineable either.
10344 elsif Is_Generic_Instance
(Subp
)
10345 or else Parent_Kind
(Parent
(Subp
)) = N_Subprogram_Declaration
10349 elsif not Comes_From_Source
(Subp
)
10350 and then Scope
(Subp
) /= Standard_Standard
10356 -- The referenced entity must either be the enclosing entity, or
10357 -- an entity declared within the current open scope.
10359 if Present
(Scope
(Subp
))
10360 and then Scope
(Subp
) /= Current_Scope
10361 and then Subp
/= Current_Scope
10364 ("argument of% must be entity in current scope", Assoc
);
10367 -- Processing for procedure, operator or function. If subprogram
10368 -- is aliased (as for an instance) indicate that the renamed
10369 -- entity (if declared in the same unit) is inlined.
10370 -- If this is the anonymous subprogram created for a subprogram
10371 -- instance, the inlining applies to it directly. Otherwise we
10372 -- retrieve it as the alias of the visible subprogram instance.
10374 if Is_Subprogram
(Subp
) then
10376 -- Ensure that pragma Inline_Always is associated with the
10377 -- initial declaration of the subprogram.
10379 Check_Inline_Always_Placement
(Subp
);
10381 if Is_Wrapper_Package
(Scope
(Subp
)) then
10382 Inner_Subp
:= Subp
;
10384 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
10387 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
10388 Set_Inline_Flags
(Inner_Subp
);
10390 if Present
(Parent
(Inner_Subp
)) then
10391 Decl
:= Parent
(Parent
(Inner_Subp
));
10396 if Nkind
(Decl
) = N_Subprogram_Declaration
10397 and then Present
(Corresponding_Body
(Decl
))
10399 Set_Inline_Flags
(Corresponding_Body
(Decl
));
10401 elsif Is_Generic_Instance
(Subp
)
10402 and then Comes_From_Source
(Subp
)
10404 -- Indicate that the body needs to be created for
10405 -- inlining subsequent calls. The instantiation node
10406 -- follows the declaration of the wrapper package
10407 -- created for it. The subprogram that requires the
10408 -- body is the anonymous one in the wrapper package.
10410 if Scope
(Subp
) /= Standard_Standard
10412 Need_Subprogram_Instance_Body
10413 (Next
(Unit_Declaration_Node
10414 (Scope
(Alias
(Subp
)))), Subp
)
10419 -- Inline is a program unit pragma (RM 10.1.5) and cannot
10420 -- appear in a formal part to apply to a formal subprogram.
10421 -- Do not apply check within an instance or a formal package
10422 -- the test will have been applied to the original generic.
10424 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
10425 and then In_Same_List
(Decl
, N
)
10426 and then not In_Instance
10429 ("Inline cannot apply to a formal subprogram", N
);
10435 -- For a generic subprogram set flag as well, for use at the point
10436 -- of instantiation, to determine whether the body should be
10439 elsif Is_Generic_Subprogram
(Subp
) then
10440 Set_Inline_Flags
(Subp
);
10443 -- Literals are by definition inlined
10445 elsif Kind
= E_Enumeration_Literal
then
10448 -- Anything else is an error
10452 ("expect subprogram name for pragma%", Assoc
);
10456 ----------------------
10457 -- Set_Inline_Flags --
10458 ----------------------
10460 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
10462 -- First set the Has_Pragma_XXX flags and issue the appropriate
10463 -- errors and warnings for suspicious combinations.
10465 if Prag_Id
= Pragma_No_Inline
then
10466 if Has_Pragma_Inline_Always
(Subp
) then
10468 ("Inline_Always and No_Inline are mutually exclusive", N
);
10469 elsif Has_Pragma_Inline
(Subp
) then
10471 ("Inline and No_Inline both specified for& ??",
10472 N
, Entity
(Subp_Id
));
10475 Set_Has_Pragma_No_Inline
(Subp
);
10477 if Prag_Id
= Pragma_Inline_Always
then
10478 if Has_Pragma_No_Inline
(Subp
) then
10480 ("Inline_Always and No_Inline are mutually exclusive",
10484 Set_Has_Pragma_Inline_Always
(Subp
);
10486 if Has_Pragma_No_Inline
(Subp
) then
10488 ("Inline and No_Inline both specified for& ??",
10489 N
, Entity
(Subp_Id
));
10493 Set_Has_Pragma_Inline
(Subp
);
10496 -- Then adjust the Is_Inlined flag. It can never be set if the
10497 -- subprogram is subject to pragma No_Inline.
10501 Set_Is_Inlined
(Subp
, False);
10507 if not Has_Pragma_No_Inline
(Subp
) then
10508 Set_Is_Inlined
(Subp
, True);
10512 -- A pragma that applies to a Ghost entity becomes Ghost for the
10513 -- purposes of legality checks and removal of ignored Ghost code.
10515 Mark_Ghost_Pragma
(N
, Subp
);
10517 -- Capture the entity of the first Ghost subprogram being
10518 -- processed for error detection purposes.
10520 if Is_Ghost_Entity
(Subp
) then
10521 if No
(Ghost_Id
) then
10525 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10526 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10528 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
10529 Ghost_Error_Posted
:= True;
10531 Error_Msg_Name_1
:= Pname
;
10533 ("pragma % cannot mention ghost and non-ghost subprograms",
10536 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
10537 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
10539 Error_Msg_Sloc
:= Sloc
(Subp
);
10540 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
10542 end Set_Inline_Flags
;
10544 -- Start of processing for Process_Inline
10547 -- An inlined subprogram may grant access to its private enclosing
10548 -- context depending on the placement of its body. From elaboration
10549 -- point of view, the flow of execution may enter this private
10550 -- context, and then reach an external unit, thus producing a
10551 -- dependency on that external unit. For such a path to be properly
10552 -- discovered and encoded in the ALI file of the main unit, let the
10553 -- ABE mechanism process the body of the main unit, and encode all
10554 -- relevant invocation constructs and the relations between them.
10556 Mark_Save_Invocation_Graph_Of_Body
;
10558 Check_No_Identifiers
;
10559 Check_At_Least_N_Arguments
(1);
10561 if Status
= Enabled
then
10562 Inline_Processing_Required
:= True;
10566 while Present
(Assoc
) loop
10567 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
10571 if Is_Entity_Name
(Subp_Id
) then
10572 Subp
:= Entity
(Subp_Id
);
10574 if Subp
= Any_Id
then
10576 -- If previous error, avoid cascaded errors
10578 Check_Error_Detected
;
10582 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10583 -- is given that directly specifies an aspect of an entity,
10584 -- then it is illegal to give another [...]
10585 -- aspect_specification that directly specifies the same
10586 -- aspect of the entity.
10587 -- We only check Subp directly as per "directly specifies"
10588 -- above and because the case of pragma Inline is really
10589 -- special given its pre aspect usage.
10591 Check_Duplicate_Pragma
(Subp
);
10592 Record_Rep_Item
(Subp
, N
);
10594 Make_Inline
(Subp
);
10596 -- For the pragma case, climb homonym chain. This is
10597 -- what implements allowing the pragma in the renaming
10598 -- case, with the result applying to the ancestors, and
10599 -- also allows Inline to apply to all previous homonyms.
10601 if not From_Aspect_Specification
(N
) then
10602 while Present
(Homonym
(Subp
))
10603 and then Scope
(Homonym
(Subp
)) = Current_Scope
10605 Subp
:= Homonym
(Subp
);
10606 Make_Inline
(Subp
);
10612 if not Applies
then
10613 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
10619 -- If the context is a package declaration, the pragma indicates
10620 -- that inlining will require the presence of the corresponding
10621 -- body. (this may be further refined).
10624 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
10625 N_Package_Declaration
10627 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
10629 end Process_Inline
;
10631 ----------------------------
10632 -- Process_Interface_Name --
10633 ----------------------------
10635 procedure Process_Interface_Name
10636 (Subprogram_Def
: Entity_Id
;
10638 Link_Arg
: Node_Id
;
10642 Link_Nam
: Node_Id
;
10643 String_Val
: String_Id
;
10645 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
10646 -- SN is a string literal node for an interface name. This routine
10647 -- performs some minimal checks that the name is reasonable. In
10648 -- particular that no spaces or other obviously incorrect characters
10649 -- appear. This is only a warning, since any characters are allowed.
10651 ----------------------------------
10652 -- Check_Form_Of_Interface_Name --
10653 ----------------------------------
10655 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
10656 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
10657 SL
: constant Nat
:= String_Length
(S
);
10662 Error_Msg_N
("interface name cannot be null string", SN
);
10665 for J
in 1 .. SL
loop
10666 C
:= Get_String_Char
(S
, J
);
10668 -- Look for dubious character and issue unconditional warning.
10669 -- Definitely dubious if not in character range.
10671 if not In_Character_Range
(C
)
10673 -- Commas, spaces and (back)slashes are dubious
10675 or else Get_Character
(C
) = ','
10676 or else Get_Character
(C
) = '\'
10677 or else Get_Character
(C
) = ' '
10678 or else Get_Character
(C
) = '/'
10681 ("??interface name contains illegal character",
10682 Sloc
(SN
) + Source_Ptr
(J
));
10685 end Check_Form_Of_Interface_Name
;
10687 -- Start of processing for Process_Interface_Name
10690 -- If we are looking at a pragma that comes from an aspect then it
10691 -- needs to have its corresponding aspect argument expressions
10692 -- analyzed in addition to the generated pragma so that aspects
10693 -- within generic units get properly resolved.
10695 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
10697 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
10705 -- Obtain all interfacing aspects used to construct the pragma
10707 Get_Interfacing_Aspects
10708 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
10710 -- Analyze the expression of aspect External_Name
10712 if Present
(EN
) then
10713 Analyze
(Expression
(EN
));
10716 -- Analyze the expressio of aspect Link_Name
10718 if Present
(LN
) then
10719 Analyze
(Expression
(LN
));
10724 if No
(Link_Arg
) then
10725 if No
(Ext_Arg
) then
10728 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10730 Link_Nam
:= Expression
(Ext_Arg
);
10733 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10734 Ext_Nam
:= Expression
(Ext_Arg
);
10739 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10740 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10741 Ext_Nam
:= Expression
(Ext_Arg
);
10742 Link_Nam
:= Expression
(Link_Arg
);
10745 -- Check expressions for external name and link name are static
10747 if Present
(Ext_Nam
) then
10748 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10749 Check_Form_Of_Interface_Name
(Ext_Nam
);
10751 -- Verify that external name is not the name of a local entity,
10752 -- which would hide the imported one and could lead to run-time
10753 -- surprises. The problem can only arise for entities declared in
10754 -- a package body (otherwise the external name is fully qualified
10755 -- and will not conflict).
10763 if Prag_Id
= Pragma_Import
then
10764 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10765 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10767 if Nam
/= Chars
(Subprogram_Def
)
10768 and then Present
(E
)
10769 and then not Is_Overloadable
(E
)
10770 and then Is_Immediately_Visible
(E
)
10771 and then not Is_Imported
(E
)
10772 and then Ekind
(Scope
(E
)) = E_Package
10775 while Present
(Par
) loop
10776 if Nkind
(Par
) = N_Package_Body
then
10777 Error_Msg_Sloc
:= Sloc
(E
);
10779 ("imported entity is hidden by & declared#",
10784 Par
:= Parent
(Par
);
10791 if Present
(Link_Nam
) then
10792 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10793 Check_Form_Of_Interface_Name
(Link_Nam
);
10796 -- If there is no link name, just set the external name
10798 if No
(Link_Nam
) then
10799 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10801 -- For the Link_Name case, the given literal is preceded by an
10802 -- asterisk, which indicates to GCC that the given name should be
10803 -- taken literally, and in particular that no prepending of
10804 -- underlines should occur, even in systems where this is the
10809 Store_String_Char
(Get_Char_Code
('*'));
10810 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10811 Store_String_Chars
(String_Val
);
10813 Make_String_Literal
(Sloc
(Link_Nam
),
10814 Strval
=> End_String
);
10817 -- Set the interface name. If the entity is a generic instance, use
10818 -- its alias, which is the callable entity.
10820 if Is_Generic_Instance
(Subprogram_Def
) then
10821 Set_Encoded_Interface_Name
10822 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10824 Set_Encoded_Interface_Name
10825 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10828 Check_Duplicated_Export_Name
(Link_Nam
);
10829 end Process_Interface_Name
;
10831 -----------------------------------------
10832 -- Process_Interrupt_Or_Attach_Handler --
10833 -----------------------------------------
10835 procedure Process_Interrupt_Or_Attach_Handler
is
10836 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10837 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10840 -- A pragma that applies to a Ghost entity becomes Ghost for the
10841 -- purposes of legality checks and removal of ignored Ghost code.
10843 Mark_Ghost_Pragma
(N
, Handler
);
10844 Set_Is_Interrupt_Handler
(Handler
);
10846 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10848 Record_Rep_Item
(Prot_Typ
, N
);
10850 -- Chain the pragma on the contract for completeness
10852 Add_Contract_Item
(N
, Handler
);
10853 end Process_Interrupt_Or_Attach_Handler
;
10855 --------------------------------------------------
10856 -- Process_Restrictions_Or_Restriction_Warnings --
10857 --------------------------------------------------
10859 -- Note: some of the simple identifier cases were handled in par-prag,
10860 -- but it is harmless (and more straightforward) to simply handle all
10861 -- cases here, even if it means we repeat a bit of work in some cases.
10863 procedure Process_Restrictions_Or_Restriction_Warnings
10867 R_Id
: Restriction_Id
;
10872 procedure Process_No_Specification_of_Aspect
;
10873 -- Process the No_Specification_of_Aspect restriction
10875 procedure Process_No_Use_Of_Attribute
;
10876 -- Process the No_Use_Of_Attribute restriction
10878 ----------------------------------------
10879 -- Process_No_Specification_of_Aspect --
10880 ----------------------------------------
10882 procedure Process_No_Specification_of_Aspect
is
10883 Name
: constant Name_Id
:= Chars
(Expr
);
10885 if Nkind
(Expr
) = N_Identifier
10886 and then Is_Aspect_Id
(Name
)
10888 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10890 Bad_Aspect
(Expr
, Name
, Warn
=> True);
10894 end Process_No_Specification_of_Aspect
;
10896 ---------------------------------
10897 -- Process_No_Use_Of_Attribute --
10898 ---------------------------------
10900 procedure Process_No_Use_Of_Attribute
is
10901 Name
: constant Name_Id
:= Chars
(Expr
);
10903 if Nkind
(Expr
) = N_Identifier
10904 and then Is_Attribute_Name
(Name
)
10906 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10908 Bad_Attribute
(Expr
, Name
, Warn
=> True);
10911 end Process_No_Use_Of_Attribute
;
10913 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
10916 -- Ignore all Restrictions pragmas in CodePeer mode
10918 if CodePeer_Mode
then
10922 Check_Ada_83_Warning
;
10923 Check_At_Least_N_Arguments
(1);
10924 Check_Valid_Configuration_Pragma
;
10927 while Present
(Arg
) loop
10929 Expr
:= Get_Pragma_Arg
(Arg
);
10931 -- Case of no restriction identifier present
10933 if Id
= No_Name
then
10934 if Nkind
(Expr
) /= N_Identifier
then
10936 ("invalid form for restriction", Arg
);
10941 (Process_Restriction_Synonyms
(Expr
));
10943 if R_Id
not in All_Boolean_Restrictions
then
10944 Error_Msg_Name_1
:= Pname
;
10946 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10948 -- Check for possible misspelling
10950 for J
in All_Restrictions
loop
10952 Rnm
: constant String := Restriction_Id
'Image (J
);
10955 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10956 Name_Len
:= Rnm
'Length;
10957 Set_Casing
(All_Lower_Case
);
10959 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10962 (Source_Index
(Current_Sem_Unit
)));
10963 Error_Msg_String
(1 .. Rnm
'Length) :=
10964 Name_Buffer
(1 .. Name_Len
);
10965 Error_Msg_Strlen
:= Rnm
'Length;
10966 Error_Msg_N
-- CODEFIX
10967 ("\possible misspelling of ""~""",
10968 Get_Pragma_Arg
(Arg
));
10977 if Implementation_Restriction
(R_Id
) then
10978 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10981 -- Special processing for No_Elaboration_Code restriction
10983 if R_Id
= No_Elaboration_Code
then
10985 -- Restriction is only recognized within a configuration
10986 -- pragma file, or within a unit of the main extended
10987 -- program. Note: the test for Main_Unit is needed to
10988 -- properly include the case of configuration pragma files.
10990 if not (Current_Sem_Unit
= Main_Unit
10991 or else In_Extended_Main_Source_Unit
(N
))
10995 -- Don't allow in a subunit unless already specified in
10998 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10999 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
11000 and then not Restriction_Active
(No_Elaboration_Code
)
11003 ("invalid specification of ""No_Elaboration_Code""",
11006 ("\restriction cannot be specified in a subunit", N
);
11008 ("\unless also specified in body or spec", N
);
11011 -- If we accept a No_Elaboration_Code restriction, then it
11012 -- needs to be added to the configuration restriction set so
11013 -- that we get proper application to other units in the main
11014 -- extended source as required.
11017 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
11020 -- Special processing for No_Dynamic_Accessibility_Checks to
11021 -- disallow exclusive specification in a body or subunit.
11023 elsif R_Id
= No_Dynamic_Accessibility_Checks
11024 -- Check if the restriction is within configuration pragma
11025 -- in a similar way to No_Elaboration_Code.
11027 and then not (Current_Sem_Unit
= Main_Unit
11028 or else In_Extended_Main_Source_Unit
(N
))
11030 and then Nkind
(Unit
(Parent
(N
))) = N_Compilation_Unit
11032 and then (Nkind
(Unit
(Parent
(N
))) = N_Package_Body
11033 or else Nkind
(Unit
(Parent
(N
))) = N_Subunit
)
11035 and then not Restriction_Active
11036 (No_Dynamic_Accessibility_Checks
)
11039 ("invalid specification of " &
11040 """No_Dynamic_Accessibility_Checks""", N
);
11042 if Nkind
(Unit
(Parent
(N
))) = N_Package_Body
then
11044 ("\restriction cannot be specified in a package " &
11047 elsif Nkind
(Unit
(Parent
(N
))) = N_Subunit
then
11049 ("\restriction cannot be specified in a subunit", N
);
11053 ("\unless also specified in spec", N
);
11055 -- Special processing for No_Tasking restriction (not just a
11056 -- warning) when it appears as a configuration pragma.
11058 elsif R_Id
= No_Tasking
11059 and then No
(Cunit
(Main_Unit
))
11062 Set_Global_No_Tasking
;
11065 Set_Restriction
(R_Id
, N
, Warn
);
11067 if R_Id
= No_Dynamic_CPU_Assignment
11068 or else R_Id
= No_Tasks_Unassigned_To_CPU
11070 -- These imply No_Dependence =>
11071 -- "System.Multiprocessors.Dispatching_Domains".
11072 -- This is not strictly what the AI says, but it eliminates
11073 -- the need for run-time checks, which are undesirable in
11076 Set_Restriction_No_Dependence
11078 (Sel_Comp
("system", "multiprocessors", Loc
),
11079 "dispatching_domains"),
11083 if R_Id
= No_Tasks_Unassigned_To_CPU
then
11084 -- Likewise, imply No_Dynamic_CPU_Assignment
11086 Set_Restriction
(No_Dynamic_CPU_Assignment
, N
, Warn
);
11089 -- Check for obsolescent restrictions in Ada 2005 mode
11092 and then Ada_Version
>= Ada_2005
11093 and then (R_Id
= No_Asynchronous_Control
11095 R_Id
= No_Unchecked_Deallocation
11097 R_Id
= No_Unchecked_Conversion
)
11099 Check_Restriction
(No_Obsolescent_Features
, N
);
11102 -- A very special case that must be processed here: pragma
11103 -- Restrictions (No_Exceptions) turns off all run-time
11104 -- checking. This is a bit dubious in terms of the formal
11105 -- language definition, but it is what is intended by RM
11106 -- H.4(12). Restriction_Warnings never affects generated code
11107 -- so this is done only in the real restriction case.
11109 -- Atomic_Synchronization is not a real check, so it is not
11110 -- affected by this processing).
11112 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
11113 -- run-time checks in CodePeer and GNATprove modes: we want to
11114 -- generate checks for analysis purposes, as set respectively
11115 -- by -gnatC and -gnatd.F
11118 and then not (CodePeer_Mode
or GNATprove_Mode
)
11119 and then R_Id
= No_Exceptions
11121 for J
in Scope_Suppress
.Suppress
'Range loop
11122 if J
/= Atomic_Synchronization
then
11123 Scope_Suppress
.Suppress
(J
) := True;
11128 -- Case of No_Dependence => unit-name. Note that the parser
11129 -- already made the necessary entry in the No_Dependence table.
11131 elsif Id
= Name_No_Dependence
then
11132 if not OK_No_Dependence_Unit_Name
(Expr
) then
11136 -- Case of No_Specification_Of_Aspect => aspect-identifier
11138 elsif Id
= Name_No_Specification_Of_Aspect
then
11139 Process_No_Specification_of_Aspect
;
11141 -- Case of No_Use_Of_Attribute => attribute-identifier
11143 elsif Id
= Name_No_Use_Of_Attribute
then
11144 Process_No_Use_Of_Attribute
;
11146 -- Case of No_Use_Of_Entity => fully-qualified-name
11148 elsif Id
= Name_No_Use_Of_Entity
then
11150 -- Restriction is only recognized within a configuration
11151 -- pragma file, or within a unit of the main extended
11152 -- program. Note: the test for Main_Unit is needed to
11153 -- properly include the case of configuration pragma files.
11155 if Current_Sem_Unit
= Main_Unit
11156 or else In_Extended_Main_Source_Unit
(N
)
11158 if not OK_No_Dependence_Unit_Name
(Expr
) then
11159 Error_Msg_N
("wrong form for entity name", Expr
);
11161 Set_Restriction_No_Use_Of_Entity
11162 (Expr
, Warn
, No_Profile
);
11166 -- Case of No_Use_Of_Pragma => pragma-identifier
11168 elsif Id
= Name_No_Use_Of_Pragma
then
11169 if Nkind
(Expr
) /= N_Identifier
11170 or else not Is_Pragma_Name
(Chars
(Expr
))
11172 Error_Msg_N
("unknown pragma name??", Expr
);
11174 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
11177 -- All other cases of restriction identifier present
11180 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
11182 if R_Id
not in All_Parameter_Restrictions
then
11184 ("invalid restriction parameter identifier", Arg
);
11187 Analyze_And_Resolve
(Expr
, Any_Integer
);
11189 if not Is_OK_Static_Expression
(Expr
) then
11190 Flag_Non_Static_Expr
11191 ("value must be static expression!", Expr
);
11194 elsif not Is_Integer_Type
(Etype
(Expr
))
11195 or else Expr_Value
(Expr
) < 0
11198 ("value must be non-negative integer", Arg
);
11201 -- Restriction pragma is active
11203 Val
:= Expr_Value
(Expr
);
11205 if not UI_Is_In_Int_Range
(Val
) then
11207 ("pragma ignored, value too large??", Arg
);
11210 Set_Restriction
(R_Id
, N
, Warn
, Integer (UI_To_Int
(Val
)));
11215 end Process_Restrictions_Or_Restriction_Warnings
;
11217 ---------------------------------
11218 -- Process_Suppress_Unsuppress --
11219 ---------------------------------
11221 -- Note: this procedure makes entries in the check suppress data
11222 -- structures managed by Sem. See spec of package Sem for full
11223 -- details on how we handle recording of check suppression.
11225 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
11230 In_Package_Spec
: constant Boolean :=
11231 Is_Package_Or_Generic_Package
(Current_Scope
)
11232 and then not In_Package_Body
(Current_Scope
);
11234 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
11235 -- Used to suppress a single check on the given entity
11237 --------------------------------
11238 -- Suppress_Unsuppress_Echeck --
11239 --------------------------------
11241 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
11243 -- Check for error of trying to set atomic synchronization for
11244 -- a non-atomic variable.
11246 if C
= Atomic_Synchronization
11247 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
11250 ("pragma & requires atomic type or variable",
11251 Pragma_Identifier
(Original_Node
(N
)));
11254 Set_Checks_May_Be_Suppressed
(E
);
11256 if In_Package_Spec
then
11257 Push_Global_Suppress_Stack_Entry
11260 Suppress
=> Suppress_Case
);
11262 Push_Local_Suppress_Stack_Entry
11265 Suppress
=> Suppress_Case
);
11268 -- If this is a first subtype, and the base type is distinct,
11269 -- then also set the suppress flags on the base type.
11271 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
11272 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
11274 end Suppress_Unsuppress_Echeck
;
11276 -- Start of processing for Process_Suppress_Unsuppress
11279 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
11280 -- on user code: we want to generate checks for analysis purposes, as
11281 -- set respectively by -gnatC and -gnatd.F
11283 if Comes_From_Source
(N
)
11284 and then (CodePeer_Mode
or GNATprove_Mode
)
11289 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
11290 -- declarative part or a package spec (RM 11.5(5)).
11292 if not Is_Configuration_Pragma
then
11293 Check_Is_In_Decl_Part_Or_Package_Spec
;
11296 Check_At_Least_N_Arguments
(1);
11297 Check_At_Most_N_Arguments
(2);
11298 Check_No_Identifier
(Arg1
);
11299 Check_Arg_Is_Identifier
(Arg1
);
11301 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
11303 if C
= No_Check_Id
then
11305 ("argument of pragma% is not valid check name", Arg1
);
11308 -- Warn that suppress of Elaboration_Check has no effect in SPARK
11310 if C
= Elaboration_Check
11311 and then Suppress_Case
11312 and then SPARK_Mode
= On
11315 ("Suppress of Elaboration_Check ignored in SPARK??",
11316 "\elaboration checking rules are statically enforced "
11317 & "(SPARK RM 7.7)", Arg1
);
11320 -- One-argument case
11322 if Arg_Count
= 1 then
11324 -- Make an entry in the local scope suppress table. This is the
11325 -- table that directly shows the current value of the scope
11326 -- suppress check for any check id value.
11328 if C
= All_Checks
then
11330 -- For All_Checks, we set all specific predefined checks with
11331 -- the exception of Elaboration_Check, which is handled
11332 -- specially because of not wanting All_Checks to have the
11333 -- effect of deactivating static elaboration order processing.
11334 -- Atomic_Synchronization is also not affected, since this is
11335 -- not a real check.
11337 for J
in Scope_Suppress
.Suppress
'Range loop
11338 if J
/= Elaboration_Check
11340 J
/= Atomic_Synchronization
11342 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
11346 -- If not All_Checks, and predefined check, then set appropriate
11347 -- scope entry. Note that we will set Elaboration_Check if this
11348 -- is explicitly specified. Atomic_Synchronization is allowed
11349 -- only if internally generated and entity is atomic.
11351 elsif C
in Predefined_Check_Id
11352 and then (not Comes_From_Source
(N
)
11353 or else C
/= Atomic_Synchronization
)
11355 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
11358 -- Also push an entry in the local suppress stack
11360 Push_Local_Suppress_Stack_Entry
11363 Suppress
=> Suppress_Case
);
11365 -- Case of two arguments present, where the check is suppressed for
11366 -- a specified entity (given as the second argument of the pragma)
11369 -- This is obsolescent in Ada 2005 mode
11371 if Ada_Version
>= Ada_2005
then
11372 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
11375 Check_Optional_Identifier
(Arg2
, Name_On
);
11376 E_Id
:= Get_Pragma_Arg
(Arg2
);
11379 if not Is_Entity_Name
(E_Id
) then
11381 ("second argument of pragma% must be entity name", Arg2
);
11384 E
:= Entity
(E_Id
);
11390 -- A pragma that applies to a Ghost entity becomes Ghost for the
11391 -- purposes of legality checks and removal of ignored Ghost code.
11393 Mark_Ghost_Pragma
(N
, E
);
11395 -- Enforce RM 11.5(7) which requires that for a pragma that
11396 -- appears within a package spec, the named entity must be
11397 -- within the package spec. We allow the package name itself
11398 -- to be mentioned since that makes sense, although it is not
11399 -- strictly allowed by 11.5(7).
11402 and then E
/= Current_Scope
11403 and then Scope
(E
) /= Current_Scope
11406 ("entity in pragma% is not in package spec (RM 11.5(7))",
11410 -- Loop through homonyms. As noted below, in the case of a package
11411 -- spec, only homonyms within the package spec are considered.
11414 Suppress_Unsuppress_Echeck
(E
, C
);
11416 if Is_Generic_Instance
(E
)
11417 and then Is_Subprogram
(E
)
11418 and then Present
(Alias
(E
))
11420 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
11423 -- Move to next homonym if not aspect spec case
11425 exit when From_Aspect_Specification
(N
);
11429 -- If we are within a package specification, the pragma only
11430 -- applies to homonyms in the same scope.
11432 exit when In_Package_Spec
11433 and then Scope
(E
) /= Current_Scope
;
11436 end Process_Suppress_Unsuppress
;
11438 -------------------------------
11439 -- Record_Independence_Check --
11440 -------------------------------
11442 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
11443 pragma Unreferenced
(N
, E
);
11445 -- For GCC back ends the validation is done a priori. This code is
11446 -- dead, but might be useful in the future.
11448 -- if not AAMP_On_Target then
11452 -- Independence_Checks.Append ((N, E));
11455 end Record_Independence_Check
;
11461 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
11463 if Is_Imported
(E
) then
11465 ("cannot export entity& that was previously imported", Arg
);
11467 elsif Present
(Address_Clause
(E
))
11468 and then not Relaxed_RM_Semantics
11471 ("cannot export entity& that has an address clause", Arg
);
11474 Set_Is_Exported
(E
);
11476 -- Generate a reference for entity explicitly, because the
11477 -- identifier may be overloaded and name resolution will not
11480 Generate_Reference
(E
, Arg
);
11482 -- Deal with exporting non-library level entity
11484 if not Is_Library_Level_Entity
(E
) then
11486 -- Not allowed at all for subprograms
11488 if Is_Subprogram
(E
) then
11489 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
11491 -- Otherwise set public and statically allocated
11495 Set_Is_Statically_Allocated
(E
);
11497 -- Warn if the corresponding W flag is set
11499 if Warn_On_Export_Import
11501 -- Only do this for something that was in the source. Not
11502 -- clear if this can be False now (there used for sure to be
11503 -- cases on some systems where it was False), but anyway the
11504 -- test is harmless if not needed, so it is retained.
11506 and then Comes_From_Source
(Arg
)
11509 ("?x?& has been made static as a result of Export",
11512 ("\?x?this usage is non-standard and non-portable",
11518 if Warn_On_Export_Import
and Inside_A_Generic
then
11520 ("all instances of& will have the same external name?x?",
11525 ----------------------------------------------
11526 -- Set_Extended_Import_Export_External_Name --
11527 ----------------------------------------------
11529 procedure Set_Extended_Import_Export_External_Name
11530 (Internal_Ent
: Entity_Id
;
11531 Arg_External
: Node_Id
)
11533 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
11534 New_Name
: Node_Id
;
11537 if No
(Arg_External
) then
11541 Check_Arg_Is_External_Name
(Arg_External
);
11543 if Nkind
(Arg_External
) = N_String_Literal
then
11544 if String_Length
(Strval
(Arg_External
)) = 0 then
11547 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
11550 elsif Nkind
(Arg_External
) = N_Identifier
then
11551 New_Name
:= Get_Default_External_Name
(Arg_External
);
11553 -- Check_Arg_Is_External_Name should let through only identifiers and
11554 -- string literals or static string expressions (which are folded to
11555 -- string literals).
11558 raise Program_Error
;
11561 -- If we already have an external name set (by a prior normal Import
11562 -- or Export pragma), then the external names must match
11564 if Present
(Interface_Name
(Internal_Ent
)) then
11566 -- Ignore mismatching names in CodePeer mode, to support some
11567 -- old compilers which would export the same procedure under
11568 -- different names, e.g:
11570 -- pragma Export_Procedure (P, "a");
11571 -- pragma Export_Procedure (P, "b");
11573 if CodePeer_Mode
then
11577 Check_Matching_Internal_Names
: declare
11578 S1
: constant String_Id
:= Strval
(Old_Name
);
11579 S2
: constant String_Id
:= Strval
(New_Name
);
11581 procedure Mismatch
;
11582 pragma No_Return
(Mismatch
);
11583 -- Called if names do not match
11589 procedure Mismatch
is
11591 Error_Msg_Sloc
:= Sloc
(Old_Name
);
11593 ("external name does not match that given #",
11597 -- Start of processing for Check_Matching_Internal_Names
11600 if String_Length
(S1
) /= String_Length
(S2
) then
11604 for J
in 1 .. String_Length
(S1
) loop
11605 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
11610 end Check_Matching_Internal_Names
;
11612 -- Otherwise set the given name
11615 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
11616 Check_Duplicated_Export_Name
(New_Name
);
11618 end Set_Extended_Import_Export_External_Name
;
11624 procedure Set_Imported
(E
: Entity_Id
) is
11626 -- Error message if already imported or exported
11628 if Is_Exported
(E
) or else Is_Imported
(E
) then
11630 -- Error if being set Exported twice
11632 if Is_Exported
(E
) then
11633 Error_Msg_NE
("entity& was previously exported", N
, E
);
11635 -- Ignore error in CodePeer mode where we treat all imported
11636 -- subprograms as unknown.
11638 elsif CodePeer_Mode
then
11641 -- OK if Import/Interface case
11643 elsif Import_Interface_Present
(N
) then
11646 -- Error if being set Imported twice
11649 Error_Msg_NE
("entity& was previously imported", N
, E
);
11652 Error_Msg_Name_1
:= Pname
;
11654 ("\(pragma% applies to all previous entities)", N
);
11656 Error_Msg_Sloc
:= Sloc
(E
);
11657 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
11659 -- Here if not previously imported or exported, OK to import
11662 Set_Is_Imported
(E
);
11664 -- For subprogram, set Import_Pragma field
11666 if Is_Subprogram
(E
) then
11667 Set_Import_Pragma
(E
, N
);
11670 -- If the entity is an object that is not at the library level,
11671 -- then it is statically allocated. We do not worry about objects
11672 -- with address clauses in this context since they are not really
11673 -- imported in the linker sense.
11676 and then not Is_Library_Level_Entity
(E
)
11677 and then No
(Address_Clause
(E
))
11679 Set_Is_Statically_Allocated
(E
);
11686 -------------------------
11687 -- Set_Mechanism_Value --
11688 -------------------------
11690 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11691 -- analyzed, since it is semantic nonsense), so we get it in the exact
11692 -- form created by the parser.
11694 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
11695 procedure Bad_Mechanism
;
11696 pragma No_Return
(Bad_Mechanism
);
11697 -- Signal bad mechanism name
11699 -------------------
11700 -- Bad_Mechanism --
11701 -------------------
11703 procedure Bad_Mechanism
is
11705 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
11708 -- Start of processing for Set_Mechanism_Value
11711 if Mechanism
(Ent
) /= Default_Mechanism
then
11713 ("mechanism for & has already been set", Mech_Name
, Ent
);
11716 -- MECHANISM_NAME ::= value | reference
11718 if Nkind
(Mech_Name
) = N_Identifier
then
11719 if Chars
(Mech_Name
) = Name_Value
then
11720 Set_Mechanism
(Ent
, By_Copy
);
11723 elsif Chars
(Mech_Name
) = Name_Reference
then
11724 Set_Mechanism
(Ent
, By_Reference
);
11727 elsif Chars
(Mech_Name
) = Name_Copy
then
11729 ("bad mechanism name, Value assumed", Mech_Name
);
11738 end Set_Mechanism_Value
;
11740 --------------------------
11741 -- Set_Rational_Profile --
11742 --------------------------
11744 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11745 -- extension to the semantics of renaming declarations.
11747 procedure Set_Rational_Profile
is
11749 Implicit_Packing
:= True;
11750 Overriding_Renamings
:= True;
11751 Use_VADS_Size
:= True;
11752 end Set_Rational_Profile
;
11754 ---------------------------
11755 -- Set_Ravenscar_Profile --
11756 ---------------------------
11758 -- The tasks to be done here are
11760 -- Set required policies
11762 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11763 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11764 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11765 -- (For GNAT_Ravenscar_EDF profile)
11766 -- pragma Locking_Policy (Ceiling_Locking)
11768 -- Set Detect_Blocking mode
11770 -- Set required restrictions (see System.Rident for detailed list)
11772 -- Set the No_Dependence rules
11773 -- No_Dependence => Ada.Asynchronous_Task_Control
11774 -- No_Dependence => Ada.Calendar
11775 -- No_Dependence => Ada.Execution_Time.Group_Budget
11776 -- No_Dependence => Ada.Execution_Time.Timers
11777 -- No_Dependence => Ada.Task_Attributes
11778 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11780 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11781 procedure Set_Error_Msg_To_Profile_Name
;
11782 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11785 -----------------------------------
11786 -- Set_Error_Msg_To_Profile_Name --
11787 -----------------------------------
11789 procedure Set_Error_Msg_To_Profile_Name
is
11790 Prof_Nam
: constant Node_Id
:=
11792 (First
(Pragma_Argument_Associations
(N
)));
11795 Get_Name_String
(Chars
(Prof_Nam
));
11796 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11797 Error_Msg_Strlen
:= Name_Len
;
11798 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11799 end Set_Error_Msg_To_Profile_Name
;
11801 Profile_Dispatching_Policy
: Character;
11803 -- Start of processing for Set_Ravenscar_Profile
11806 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11808 if Profile
= GNAT_Ravenscar_EDF
then
11809 Profile_Dispatching_Policy
:= 'E';
11811 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11814 Profile_Dispatching_Policy
:= 'F';
11817 if Task_Dispatching_Policy
/= ' '
11818 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11820 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11821 Set_Error_Msg_To_Profile_Name
;
11822 Error_Pragma
("Profile (~) incompatible with policy#");
11824 -- Set the FIFO_Within_Priorities policy, but always preserve
11825 -- System_Location since we like the error message with the run time
11829 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11831 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11832 Task_Dispatching_Policy_Sloc
:= Loc
;
11836 -- pragma Locking_Policy (Ceiling_Locking)
11838 if Locking_Policy
/= ' '
11839 and then Locking_Policy
/= 'C'
11841 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11842 Set_Error_Msg_To_Profile_Name
;
11843 Error_Pragma
("Profile (~) incompatible with policy#");
11845 -- Set the Ceiling_Locking policy, but preserve System_Location since
11846 -- we like the error message with the run time name.
11849 Locking_Policy
:= 'C';
11851 if Locking_Policy_Sloc
/= System_Location
then
11852 Locking_Policy_Sloc
:= Loc
;
11856 -- pragma Detect_Blocking
11858 Detect_Blocking
:= True;
11860 -- Set the corresponding restrictions
11862 Set_Profile_Restrictions
11863 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11865 -- Set the No_Dependence restrictions
11867 -- The following No_Dependence restrictions:
11868 -- No_Dependence => Ada.Asynchronous_Task_Control
11869 -- No_Dependence => Ada.Calendar
11870 -- No_Dependence => Ada.Task_Attributes
11871 -- are already set by previous call to Set_Profile_Restrictions.
11874 -- Set the following restrictions which were added to Ada 2005:
11875 -- No_Dependence => Ada.Execution_Time.Group_Budget
11876 -- No_Dependence => Ada.Execution_Time.Timers
11878 if Ada_Version
>= Ada_2005
then
11880 Execution_Time
: constant Node_Id
:=
11881 Sel_Comp
("ada", "execution_time", Loc
);
11882 Group_Budgets
: constant Node_Id
:=
11883 Sel_Comp
(Execution_Time
, "group_budgets");
11884 Timers
: constant Node_Id
:=
11885 Sel_Comp
(Execution_Time
, "timers");
11887 Set_Restriction_No_Dependence
11888 (Unit
=> Group_Budgets
,
11889 Warn
=> Treat_Restrictions_As_Warnings
,
11890 Profile
=> Ravenscar
);
11891 Set_Restriction_No_Dependence
11893 Warn
=> Treat_Restrictions_As_Warnings
,
11894 Profile
=> Ravenscar
);
11898 -- Set the following restriction which was added to Ada 2012 (see
11900 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11902 if Ada_Version
>= Ada_2012
then
11903 Set_Restriction_No_Dependence
11905 (Sel_Comp
("system", "multiprocessors", Loc
),
11906 "dispatching_domains"),
11907 Warn
=> Treat_Restrictions_As_Warnings
,
11908 Profile
=> Ravenscar
);
11910 -- Set the following restriction which was added to Ada 2022,
11911 -- but as a binding interpretation:
11912 -- No_Dependence => Ada.Synchronous_Barriers
11913 -- for Ravenscar (and therefore for Ravenscar variants) but not
11914 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11915 -- in Ada2012 (AI05-0174).
11917 if Profile
/= Jorvik
then
11918 Set_Restriction_No_Dependence
11919 (Sel_Comp
("ada", "synchronous_barriers", Loc
),
11920 Warn
=> Treat_Restrictions_As_Warnings
,
11921 Profile
=> Ravenscar
);
11925 end Set_Ravenscar_Profile
;
11927 -- Start of processing for Analyze_Pragma
11930 -- The following code is a defense against recursion. Not clear that
11931 -- this can happen legitimately, but perhaps some error situations can
11932 -- cause it, and we did see this recursion during testing.
11934 if Analyzed
(N
) then
11940 Check_Restriction_No_Use_Of_Pragma
(N
);
11942 if Is_Aspect_Id
(Chars
(Pragma_Identifier
(N
))) then
11943 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11944 -- no aspect_specification, attribute_definition_clause, or pragma
11946 Check_Restriction_No_Specification_Of_Aspect
(N
);
11949 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11950 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11952 if Should_Ignore_Pragma_Sem
(N
)
11953 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11954 and then Ignore_Rep_Clauses
)
11959 -- Deal with unrecognized pragma
11961 if not Is_Pragma_Name
(Pname
) then
11963 Msg_Issued
: Boolean := False;
11966 (Msg_Issued
, No_Unrecognized_Pragmas
, Pragma_Identifier
(N
));
11967 if not Msg_Issued
and then Warn_On_Unrecognized_Pragma
then
11968 Error_Msg_Name_1
:= Pname
;
11969 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11971 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11972 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11973 Error_Msg_Name_1
:= PN
;
11974 Error_Msg_N
-- CODEFIX
11975 ("\?g?possible misspelling of %!",
11976 Pragma_Identifier
(N
));
11986 -- Here to start processing for recognized pragma
11988 Pname
:= Original_Aspect_Pragma_Name
(N
);
11990 -- Capture setting of Opt.Uneval_Old
11992 case Opt
.Uneval_Old
is
11994 Set_Uneval_Old_Accept
(N
);
12000 Set_Uneval_Old_Warn
(N
);
12003 raise Program_Error
;
12006 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
12007 -- is already set, indicating that we have already checked the policy
12008 -- at the right point. This happens for example in the case of a pragma
12009 -- that is derived from an Aspect.
12011 if Is_Ignored
(N
) or else Is_Checked
(N
) then
12014 -- For a pragma that is a rewriting of another pragma, copy the
12015 -- Is_Checked/Is_Ignored status from the rewritten pragma.
12017 elsif Is_Rewrite_Substitution
(N
)
12018 and then Nkind
(Original_Node
(N
)) = N_Pragma
12020 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12021 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12023 -- Otherwise query the applicable policy at this point
12026 Check_Applicable_Policy
(N
);
12028 -- If pragma is disabled, rewrite as NULL and skip analysis
12030 if Is_Disabled
(N
) then
12031 Rewrite
(N
, Make_Null_Statement
(Loc
));
12037 -- Mark assertion pragmas as Ghost depending on their enclosing context
12039 if Assertion_Expression_Pragma
(Prag_Id
) then
12040 Mark_Ghost_Pragma
(N
, Current_Scope
);
12043 -- Preset arguments
12045 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
12046 Arg1
:= First
(Pragma_Argument_Associations
(N
));
12052 if Present
(Arg1
) then
12053 Arg2
:= Next
(Arg1
);
12055 if Present
(Arg2
) then
12056 Arg3
:= Next
(Arg2
);
12058 if Present
(Arg3
) then
12059 Arg4
:= Next
(Arg3
);
12061 if Present
(Arg4
) then
12062 Arg5
:= Next
(Arg4
);
12068 -- An enumeration type defines the pragmas that are supported by the
12069 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
12070 -- into the corresponding enumeration value for the following case.
12078 -- pragma Abort_Defer;
12080 when Pragma_Abort_Defer
=>
12082 Check_Arg_Count
(0);
12084 -- The only required semantic processing is to check the
12085 -- placement. This pragma must appear at the start of the
12086 -- statement sequence of a handled sequence of statements.
12088 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
12089 or else N
/= First
(Statements
(Parent
(N
)))
12094 --------------------
12095 -- Abstract_State --
12096 --------------------
12098 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
12100 -- ABSTRACT_STATE_LIST ::=
12102 -- | STATE_NAME_WITH_OPTIONS
12103 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
12105 -- STATE_NAME_WITH_OPTIONS ::=
12107 -- | (STATE_NAME with OPTION_LIST)
12109 -- OPTION_LIST ::= OPTION {, OPTION}
12113 -- | NAME_VALUE_OPTION
12115 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
12117 -- NAME_VALUE_OPTION ::=
12118 -- Part_Of => ABSTRACT_STATE
12119 -- | External [=> EXTERNAL_PROPERTY_LIST]
12121 -- EXTERNAL_PROPERTY_LIST ::=
12122 -- EXTERNAL_PROPERTY
12123 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
12125 -- EXTERNAL_PROPERTY ::=
12126 -- Async_Readers [=> boolean_EXPRESSION]
12127 -- | Async_Writers [=> boolean_EXPRESSION]
12128 -- | Effective_Reads [=> boolean_EXPRESSION]
12129 -- | Effective_Writes [=> boolean_EXPRESSION]
12130 -- others => boolean_EXPRESSION
12132 -- STATE_NAME ::= defining_identifier
12134 -- ABSTRACT_STATE ::= name
12136 -- Characteristics:
12138 -- * Analysis - The annotation is fully analyzed immediately upon
12139 -- elaboration as it cannot forward reference entities.
12141 -- * Expansion - None.
12143 -- * Template - The annotation utilizes the generic template of the
12144 -- related package declaration.
12146 -- * Globals - The annotation cannot reference global entities.
12148 -- * Instance - The annotation is instantiated automatically when
12149 -- the related generic package is instantiated.
12151 when Pragma_Abstract_State
=> Abstract_State
: declare
12152 Missing_Parentheses
: Boolean := False;
12153 -- Flag set when a state declaration with options is not properly
12156 -- Flags used to verify the consistency of states
12158 Non_Null_Seen
: Boolean := False;
12159 Null_Seen
: Boolean := False;
12161 procedure Analyze_Abstract_State
12163 Pack_Id
: Entity_Id
);
12164 -- Verify the legality of a single state declaration. Create and
12165 -- decorate a state abstraction entity and introduce it into the
12166 -- visibility chain. Pack_Id denotes the entity or the related
12167 -- package where pragma Abstract_State appears.
12169 procedure Malformed_State_Error
(State
: Node_Id
);
12170 -- Emit an error concerning the illegal declaration of abstract
12171 -- state State. This routine diagnoses syntax errors that lead to
12172 -- a different parse tree. The error is issued regardless of the
12173 -- SPARK mode in effect.
12175 ----------------------------
12176 -- Analyze_Abstract_State --
12177 ----------------------------
12179 procedure Analyze_Abstract_State
12181 Pack_Id
: Entity_Id
)
12183 -- Flags used to verify the consistency of options
12185 AR_Seen
: Boolean := False;
12186 AW_Seen
: Boolean := False;
12187 ER_Seen
: Boolean := False;
12188 EW_Seen
: Boolean := False;
12189 External_Seen
: Boolean := False;
12190 Ghost_Seen
: Boolean := False;
12191 Others_Seen
: Boolean := False;
12192 Part_Of_Seen
: Boolean := False;
12193 Relaxed_Initialization_Seen
: Boolean := False;
12194 Synchronous_Seen
: Boolean := False;
12196 -- Flags used to store the static value of all external states'
12199 AR_Val
: Boolean := False;
12200 AW_Val
: Boolean := False;
12201 ER_Val
: Boolean := False;
12202 EW_Val
: Boolean := False;
12204 State_Id
: Entity_Id
:= Empty
;
12205 -- The entity to be generated for the current state declaration
12207 procedure Analyze_External_Option
(Opt
: Node_Id
);
12208 -- Verify the legality of option External
12210 procedure Analyze_External_Property
12212 Expr
: Node_Id
:= Empty
);
12213 -- Verify the legailty of a single external property. Prop
12214 -- denotes the external property. Expr is the expression used
12215 -- to set the property.
12217 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
12218 -- Verify the legality of option Part_Of
12220 procedure Check_Duplicate_Option
12222 Status
: in out Boolean);
12223 -- Flag Status denotes whether a particular option has been
12224 -- seen while processing a state. This routine verifies that
12225 -- Opt is not a duplicate option and sets the flag Status
12226 -- (SPARK RM 7.1.4(1)).
12228 procedure Check_Duplicate_Property
12230 Status
: in out Boolean);
12231 -- Flag Status denotes whether a particular property has been
12232 -- seen while processing option External. This routine verifies
12233 -- that Prop is not a duplicate property and sets flag Status.
12234 -- Opt is not a duplicate property and sets the flag Status.
12235 -- (SPARK RM 7.1.4(2))
12237 procedure Check_Ghost_Synchronous
;
12238 -- Ensure that the abstract state is not subject to both Ghost
12239 -- and Synchronous simple options. Emit an error if this is the
12242 procedure Create_Abstract_State
12246 Is_Null
: Boolean);
12247 -- Generate an abstract state entity with name Nam and enter it
12248 -- into visibility. Decl is the "declaration" of the state as
12249 -- it appears in pragma Abstract_State. Loc is the location of
12250 -- the related state "declaration". Flag Is_Null should be set
12251 -- when the associated Abstract_State pragma defines a null
12254 -----------------------------
12255 -- Analyze_External_Option --
12256 -----------------------------
12258 procedure Analyze_External_Option
(Opt
: Node_Id
) is
12259 Errors
: constant Nat
:= Serious_Errors_Detected
;
12261 Props
: Node_Id
:= Empty
;
12264 if Nkind
(Opt
) = N_Component_Association
then
12265 Props
:= Expression
(Opt
);
12268 -- External state with properties
12270 if Present
(Props
) then
12272 -- Multiple properties appear as an aggregate
12274 if Nkind
(Props
) = N_Aggregate
then
12276 -- Simple property form
12278 Prop
:= First
(Expressions
(Props
));
12279 while Present
(Prop
) loop
12280 Analyze_External_Property
(Prop
);
12284 -- Property with expression form
12286 Prop
:= First
(Component_Associations
(Props
));
12287 while Present
(Prop
) loop
12288 Analyze_External_Property
12289 (Prop
=> First
(Choices
(Prop
)),
12290 Expr
=> Expression
(Prop
));
12298 Analyze_External_Property
(Props
);
12301 -- An external state defined without any properties defaults
12302 -- all properties to True.
12311 -- Once all external properties have been processed, verify
12312 -- their mutual interaction. Do not perform the check when
12313 -- at least one of the properties is illegal as this will
12314 -- produce a bogus error.
12316 if Errors
= Serious_Errors_Detected
then
12317 Check_External_Properties
12318 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
12320 end Analyze_External_Option
;
12322 -------------------------------
12323 -- Analyze_External_Property --
12324 -------------------------------
12326 procedure Analyze_External_Property
12328 Expr
: Node_Id
:= Empty
)
12330 Expr_Val
: Boolean;
12333 -- Check the placement of "others" (if available)
12335 if Nkind
(Prop
) = N_Others_Choice
then
12336 if Others_Seen
then
12338 ("only one OTHERS choice allowed in option External",
12341 Others_Seen
:= True;
12344 elsif Others_Seen
then
12346 ("OTHERS must be the last property in option External",
12349 -- The only remaining legal options are the four predefined
12350 -- external properties.
12352 elsif Nkind
(Prop
) = N_Identifier
12353 and then Chars
(Prop
) in Name_Async_Readers
12354 | Name_Async_Writers
12355 | Name_Effective_Reads
12356 | Name_Effective_Writes
12360 -- Otherwise the construct is not a valid property
12363 SPARK_Msg_N
("invalid external state property", Prop
);
12367 -- Ensure that the expression of the external state property
12368 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12370 if Present
(Expr
) then
12371 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
12373 if Is_OK_Static_Expression
(Expr
) then
12374 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
12377 ("expression of external state property must be "
12382 -- The lack of expression defaults the property to True
12388 -- Named properties
12390 if Nkind
(Prop
) = N_Identifier
then
12391 if Chars
(Prop
) = Name_Async_Readers
then
12392 Check_Duplicate_Property
(Prop
, AR_Seen
);
12393 AR_Val
:= Expr_Val
;
12395 elsif Chars
(Prop
) = Name_Async_Writers
then
12396 Check_Duplicate_Property
(Prop
, AW_Seen
);
12397 AW_Val
:= Expr_Val
;
12399 elsif Chars
(Prop
) = Name_Effective_Reads
then
12400 Check_Duplicate_Property
(Prop
, ER_Seen
);
12401 ER_Val
:= Expr_Val
;
12404 Check_Duplicate_Property
(Prop
, EW_Seen
);
12405 EW_Val
:= Expr_Val
;
12408 -- The handling of property "others" must take into account
12409 -- all other named properties that have been encountered so
12410 -- far. Only those that have not been seen are affected by
12414 if not AR_Seen
then
12415 AR_Val
:= Expr_Val
;
12418 if not AW_Seen
then
12419 AW_Val
:= Expr_Val
;
12422 if not ER_Seen
then
12423 ER_Val
:= Expr_Val
;
12426 if not EW_Seen
then
12427 EW_Val
:= Expr_Val
;
12430 end Analyze_External_Property
;
12432 ----------------------------
12433 -- Analyze_Part_Of_Option --
12434 ----------------------------
12436 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
12437 Encap
: constant Node_Id
:= Expression
(Opt
);
12438 Constits
: Elist_Id
;
12439 Encap_Id
: Entity_Id
;
12443 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
12446 (Indic
=> First
(Choices
(Opt
)),
12447 Item_Id
=> State_Id
,
12449 Encap_Id
=> Encap_Id
,
12452 -- The Part_Of indicator transforms the abstract state into
12453 -- a constituent of the encapsulating state or single
12454 -- concurrent type.
12457 pragma Assert
(Present
(Encap_Id
));
12458 Constits
:= Part_Of_Constituents
(Encap_Id
);
12460 if No
(Constits
) then
12461 Constits
:= New_Elmt_List
;
12462 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12465 Append_Elmt
(State_Id
, Constits
);
12466 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12468 end Analyze_Part_Of_Option
;
12470 ----------------------------
12471 -- Check_Duplicate_Option --
12472 ----------------------------
12474 procedure Check_Duplicate_Option
12476 Status
: in out Boolean)
12480 SPARK_Msg_N
("duplicate state option", Opt
);
12484 end Check_Duplicate_Option
;
12486 ------------------------------
12487 -- Check_Duplicate_Property --
12488 ------------------------------
12490 procedure Check_Duplicate_Property
12492 Status
: in out Boolean)
12496 SPARK_Msg_N
("duplicate external property", Prop
);
12500 end Check_Duplicate_Property
;
12502 -----------------------------
12503 -- Check_Ghost_Synchronous --
12504 -----------------------------
12506 procedure Check_Ghost_Synchronous
is
12508 -- A synchronized abstract state cannot be Ghost and vice
12509 -- versa (SPARK RM 6.9(19)).
12511 if Ghost_Seen
and Synchronous_Seen
then
12512 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12514 end Check_Ghost_Synchronous
;
12516 ---------------------------
12517 -- Create_Abstract_State --
12518 ---------------------------
12520 procedure Create_Abstract_State
12527 -- The abstract state may be semi-declared when the related
12528 -- package was withed through a limited with clause. In that
12529 -- case reuse the entity to fully declare the state.
12531 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12532 State_Id
:= Entity
(Decl
);
12534 -- Otherwise the elaboration of pragma Abstract_State
12535 -- declares the state.
12538 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12540 if Present
(Decl
) then
12541 Set_Entity
(Decl
, State_Id
);
12545 -- Null states never come from source
12547 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12548 Set_Parent
(State_Id
, State
);
12549 Mutate_Ekind
(State_Id
, E_Abstract_State
);
12550 Set_Is_Not_Self_Hidden
(State_Id
);
12551 Set_Etype
(State_Id
, Standard_Void_Type
);
12552 Set_Encapsulating_State
(State_Id
, Empty
);
12554 -- Set the SPARK mode from the current context
12556 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12557 Set_SPARK_Pragma_Inherited
(State_Id
);
12559 -- An abstract state declared within a Ghost region becomes
12560 -- Ghost (SPARK RM 6.9(2)).
12562 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12563 Set_Is_Ghost_Entity
(State_Id
);
12566 -- Establish a link between the state declaration and the
12567 -- abstract state entity. Note that a null state remains as
12568 -- N_Null and does not carry any linkages.
12570 if not Is_Null
then
12571 if Present
(Decl
) then
12572 Set_Entity
(Decl
, State_Id
);
12573 Set_Etype
(Decl
, Standard_Void_Type
);
12576 -- Every non-null state must be defined, nameable and
12579 Push_Scope
(Pack_Id
);
12580 Generate_Definition
(State_Id
);
12581 Enter_Name
(State_Id
);
12584 end Create_Abstract_State
;
12591 -- Start of processing for Analyze_Abstract_State
12594 -- A package with a null abstract state is not allowed to
12595 -- declare additional states.
12599 ("package & has null abstract state", State
, Pack_Id
);
12601 -- Null states appear as internally generated entities
12603 elsif Nkind
(State
) = N_Null
then
12604 Create_Abstract_State
12605 (Nam
=> New_Internal_Name
('S'),
12607 Loc
=> Sloc
(State
),
12611 -- Catch a case where a null state appears in a list of
12612 -- non-null states.
12614 if Non_Null_Seen
then
12616 ("package & has non-null abstract state",
12620 -- Simple state declaration
12622 elsif Nkind
(State
) = N_Identifier
then
12623 Create_Abstract_State
12624 (Nam
=> Chars
(State
),
12626 Loc
=> Sloc
(State
),
12628 Non_Null_Seen
:= True;
12630 -- State declaration with various options. This construct
12631 -- appears as an extension aggregate in the tree.
12633 elsif Nkind
(State
) = N_Extension_Aggregate
then
12634 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12635 Create_Abstract_State
12636 (Nam
=> Chars
(Ancestor_Part
(State
)),
12637 Decl
=> Ancestor_Part
(State
),
12638 Loc
=> Sloc
(Ancestor_Part
(State
)),
12640 Non_Null_Seen
:= True;
12643 ("state name must be an identifier",
12644 Ancestor_Part
(State
));
12647 -- Options External, Ghost and Synchronous appear as
12650 Opt
:= First
(Expressions
(State
));
12651 while Present
(Opt
) loop
12652 if Nkind
(Opt
) = N_Identifier
then
12656 if Chars
(Opt
) = Name_External
then
12657 Check_Duplicate_Option
(Opt
, External_Seen
);
12658 Analyze_External_Option
(Opt
);
12662 elsif Chars
(Opt
) = Name_Ghost
then
12663 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12664 Check_Ghost_Synchronous
;
12666 if Present
(State_Id
) then
12667 Set_Is_Ghost_Entity
(State_Id
);
12672 elsif Chars
(Opt
) = Name_Synchronous
then
12673 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12674 Check_Ghost_Synchronous
;
12676 -- Relaxed_Initialization
12678 elsif Chars
(Opt
) = Name_Relaxed_Initialization
then
12679 Check_Duplicate_Option
12680 (Opt
, Relaxed_Initialization_Seen
);
12682 -- Option Part_Of without an encapsulating state is
12683 -- illegal (SPARK RM 7.1.4(8)).
12685 elsif Chars
(Opt
) = Name_Part_Of
then
12687 ("indicator Part_Of must denote abstract state, "
12688 & "single protected type or single task type",
12691 -- Do not emit an error message when a previous state
12692 -- declaration with options was not parenthesized as
12693 -- the option is actually another state declaration.
12695 -- with Abstract_State
12696 -- (State_1 with ..., -- missing parentheses
12697 -- (State_2 with ...),
12698 -- State_3) -- ok state declaration
12700 elsif Missing_Parentheses
then
12703 -- Otherwise the option is not allowed. Note that it
12704 -- is not possible to distinguish between an option
12705 -- and a state declaration when a previous state with
12706 -- options not properly parentheses.
12708 -- with Abstract_State
12709 -- (State_1 with ..., -- missing parentheses
12710 -- State_2); -- could be an option
12714 ("simple option not allowed in state declaration",
12718 -- Catch a case where missing parentheses around a state
12719 -- declaration with options cause a subsequent state
12720 -- declaration with options to be treated as an option.
12722 -- with Abstract_State
12723 -- (State_1 with ..., -- missing parentheses
12724 -- (State_2 with ...))
12726 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12727 Missing_Parentheses
:= True;
12729 ("state declaration must be parenthesized",
12730 Ancestor_Part
(State
));
12732 -- Otherwise the option is malformed
12735 SPARK_Msg_N
("malformed option", Opt
);
12741 -- Options External and Part_Of appear as component
12744 Opt
:= First
(Component_Associations
(State
));
12745 while Present
(Opt
) loop
12746 Opt_Nam
:= First
(Choices
(Opt
));
12748 if Nkind
(Opt_Nam
) = N_Identifier
then
12749 if Chars
(Opt_Nam
) = Name_External
then
12750 Analyze_External_Option
(Opt
);
12752 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12753 Analyze_Part_Of_Option
(Opt
);
12756 SPARK_Msg_N
("invalid state option", Opt
);
12759 SPARK_Msg_N
("invalid state option", Opt
);
12765 -- Any other attempt to declare a state is illegal
12768 Malformed_State_Error
(State
);
12772 -- Guard against a junk state. In such cases no entity is
12773 -- generated and the subsequent checks cannot be applied.
12775 if Present
(State_Id
) then
12777 -- Verify whether the state does not introduce an illegal
12778 -- hidden state within a package subject to a null abstract
12781 Check_No_Hidden_State
(State_Id
);
12783 -- Check whether the lack of option Part_Of agrees with the
12784 -- placement of the abstract state with respect to the state
12787 if not Part_Of_Seen
then
12788 Check_Missing_Part_Of
(State_Id
);
12791 -- Associate the state with its related package
12793 if No
(Abstract_States
(Pack_Id
)) then
12794 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12797 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12799 end Analyze_Abstract_State
;
12801 ---------------------------
12802 -- Malformed_State_Error --
12803 ---------------------------
12805 procedure Malformed_State_Error
(State
: Node_Id
) is
12807 Error_Msg_N
("malformed abstract state declaration", State
);
12809 -- An abstract state with a simple option is being declared
12810 -- with "=>" rather than the legal "with". The state appears
12811 -- as a component association.
12813 if Nkind
(State
) = N_Component_Association
then
12814 Error_Msg_N
("\use WITH to specify simple option", State
);
12816 end Malformed_State_Error
;
12820 Pack_Decl
: Node_Id
;
12821 Pack_Id
: Entity_Id
;
12825 -- Start of processing for Abstract_State
12829 Check_No_Identifiers
;
12830 Check_Arg_Count
(1);
12832 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12834 if Nkind
(Pack_Decl
) not in
12835 N_Generic_Package_Declaration | N_Package_Declaration
12840 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12842 -- A pragma that applies to a Ghost entity becomes Ghost for the
12843 -- purposes of legality checks and removal of ignored Ghost code.
12845 Mark_Ghost_Pragma
(N
, Pack_Id
);
12846 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12848 -- Chain the pragma on the contract for completeness
12850 Add_Contract_Item
(N
, Pack_Id
);
12852 -- The legality checks of pragmas Abstract_State, Initializes, and
12853 -- Initial_Condition are affected by the SPARK mode in effect. In
12854 -- addition, these three pragmas are subject to an inherent order:
12856 -- 1) Abstract_State
12858 -- 3) Initial_Condition
12860 -- Analyze all these pragmas in the order outlined above
12862 Analyze_If_Present
(Pragma_SPARK_Mode
);
12863 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12865 -- Multiple non-null abstract states appear as an aggregate
12867 if Nkind
(States
) = N_Aggregate
then
12868 State
:= First
(Expressions
(States
));
12869 while Present
(State
) loop
12870 Analyze_Abstract_State
(State
, Pack_Id
);
12874 -- An abstract state with a simple option is being illegaly
12875 -- declared with "=>" rather than "with". In this case the
12876 -- state declaration appears as a component association.
12878 if Present
(Component_Associations
(States
)) then
12879 State
:= First
(Component_Associations
(States
));
12880 while Present
(State
) loop
12881 Malformed_State_Error
(State
);
12886 -- Various forms of a single abstract state. Note that these may
12887 -- include malformed state declarations.
12890 Analyze_Abstract_State
(States
, Pack_Id
);
12893 Analyze_If_Present
(Pragma_Initializes
);
12894 Analyze_If_Present
(Pragma_Initial_Condition
);
12895 end Abstract_State
;
12903 -- Note: this pragma also has some specific processing in Par.Prag
12904 -- because we want to set the Ada version mode during parsing.
12906 when Pragma_Ada_83
=>
12908 Check_Arg_Count
(0);
12910 -- We really should check unconditionally for proper configuration
12911 -- pragma placement, since we really don't want mixed Ada modes
12912 -- within a single unit, and the GNAT reference manual has always
12913 -- said this was a configuration pragma, but we did not check and
12914 -- are hesitant to add the check now.
12916 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12917 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12918 -- or Ada 2012 mode.
12920 if Ada_Version
>= Ada_2005
then
12921 Check_Valid_Configuration_Pragma
;
12924 -- Now set Ada 83 mode
12926 if Latest_Ada_Only
then
12927 Error_Pragma
("??pragma% ignored");
12929 Ada_Version
:= Ada_83
;
12930 Ada_Version_Explicit
:= Ada_83
;
12931 Ada_Version_Pragma
:= N
;
12940 -- Note: this pragma also has some specific processing in Par.Prag
12941 -- because we want to set the Ada 83 version mode during parsing.
12943 when Pragma_Ada_95
=>
12945 Check_Arg_Count
(0);
12947 -- We really should check unconditionally for proper configuration
12948 -- pragma placement, since we really don't want mixed Ada modes
12949 -- within a single unit, and the GNAT reference manual has always
12950 -- said this was a configuration pragma, but we did not check and
12951 -- are hesitant to add the check now.
12953 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12954 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12956 if Ada_Version
>= Ada_2005
then
12957 Check_Valid_Configuration_Pragma
;
12960 -- Now set Ada 95 mode
12962 if Latest_Ada_Only
then
12963 Error_Pragma
("??pragma% ignored");
12965 Ada_Version
:= Ada_95
;
12966 Ada_Version_Explicit
:= Ada_95
;
12967 Ada_Version_Pragma
:= N
;
12970 ---------------------
12971 -- Ada_05/Ada_2005 --
12972 ---------------------
12975 -- pragma Ada_05 (LOCAL_NAME);
12977 -- pragma Ada_2005;
12978 -- pragma Ada_2005 (LOCAL_NAME):
12980 -- Note: these pragmas also have some specific processing in Par.Prag
12981 -- because we want to set the Ada 2005 version mode during parsing.
12983 -- The one argument form is used for managing the transition from
12984 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12985 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12986 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12987 -- mode, a preference rule is established which does not choose
12988 -- such an entity unless it is unambiguously specified. This avoids
12989 -- extra subprograms marked this way from generating ambiguities in
12990 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12991 -- intended for exclusive use in the GNAT run-time library.
13002 if Arg_Count
= 1 then
13003 Check_Arg_Is_Local_Name
(Arg1
);
13004 E_Id
:= Get_Pragma_Arg
(Arg1
);
13006 if Etype
(E_Id
) = Any_Type
then
13010 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
13011 Record_Rep_Item
(Entity
(E_Id
), N
);
13014 Check_Arg_Count
(0);
13016 -- For Ada_2005 we unconditionally enforce the documented
13017 -- configuration pragma placement, since we do not want to
13018 -- tolerate mixed modes in a unit involving Ada 2005. That
13019 -- would cause real difficulties for those cases where there
13020 -- are incompatibilities between Ada 95 and Ada 2005.
13022 Check_Valid_Configuration_Pragma
;
13024 -- Now set appropriate Ada mode
13026 if Latest_Ada_Only
then
13027 Error_Pragma
("??pragma% ignored");
13029 Ada_Version
:= Ada_2005
;
13030 Ada_Version_Explicit
:= Ada_2005
;
13031 Ada_Version_Pragma
:= N
;
13036 ---------------------
13037 -- Ada_12/Ada_2012 --
13038 ---------------------
13041 -- pragma Ada_12 (LOCAL_NAME);
13043 -- pragma Ada_2012;
13044 -- pragma Ada_2012 (LOCAL_NAME):
13046 -- Note: these pragmas also have some specific processing in Par.Prag
13047 -- because we want to set the Ada 2012 version mode during parsing.
13049 -- The one argument form is used for managing the transition from Ada
13050 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
13051 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
13052 -- mode will generate a warning. In addition, in any pre-Ada_2012
13053 -- mode, a preference rule is established which does not choose
13054 -- such an entity unless it is unambiguously specified. This avoids
13055 -- extra subprograms marked this way from generating ambiguities in
13056 -- otherwise legal pre-Ada_2012 programs. The one argument form is
13057 -- intended for exclusive use in the GNAT run-time library.
13068 if Arg_Count
= 1 then
13069 Check_Arg_Is_Local_Name
(Arg1
);
13070 E_Id
:= Get_Pragma_Arg
(Arg1
);
13072 if Etype
(E_Id
) = Any_Type
then
13076 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
13077 Record_Rep_Item
(Entity
(E_Id
), N
);
13080 Check_Arg_Count
(0);
13082 -- For Ada_2012 we unconditionally enforce the documented
13083 -- configuration pragma placement, since we do not want to
13084 -- tolerate mixed modes in a unit involving Ada 2012. That
13085 -- would cause real difficulties for those cases where there
13086 -- are incompatibilities between Ada 95 and Ada 2012. We could
13087 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
13089 Check_Valid_Configuration_Pragma
;
13091 -- Now set appropriate Ada mode
13093 Ada_Version
:= Ada_2012
;
13094 Ada_Version_Explicit
:= Ada_2012
;
13095 Ada_Version_Pragma
:= N
;
13103 -- pragma Ada_2022;
13104 -- pragma Ada_2022 (LOCAL_NAME):
13106 -- Note: this pragma also has some specific processing in Par.Prag
13107 -- because we want to set the Ada 2022 version mode during parsing.
13109 -- The one argument form is used for managing the transition from Ada
13110 -- 2012 to Ada 2022 in the run-time library. If an entity is marked
13111 -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
13112 -- mode will generate a warning;for calls to Ada_2022 only primitives
13113 -- that require overriding an error will be reported. In addition, in
13114 -- any pre-Ada_2022 mode, a preference rule is established which does
13115 -- not choose such an entity unless it is unambiguously specified.
13116 -- This avoids extra subprograms marked this way from generating
13117 -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
13118 -- argument form is intended for exclusive use in the GNAT run-time
13121 when Pragma_Ada_2022
=>
13128 if Arg_Count
= 1 then
13129 Check_Arg_Is_Local_Name
(Arg1
);
13130 E_Id
:= Get_Pragma_Arg
(Arg1
);
13132 if Etype
(E_Id
) = Any_Type
then
13136 Set_Is_Ada_2022_Only
(Entity
(E_Id
));
13137 Record_Rep_Item
(Entity
(E_Id
), N
);
13140 Check_Arg_Count
(0);
13142 -- For Ada_2022 we unconditionally enforce the documented
13143 -- configuration pragma placement, since we do not want to
13144 -- tolerate mixed modes in a unit involving Ada 2022. That
13145 -- would cause real difficulties for those cases where there
13146 -- are incompatibilities between Ada 2012 and Ada 2022. We
13147 -- could allow mixing of Ada 2012 and Ada 2022 but it's not
13150 Check_Valid_Configuration_Pragma
;
13152 -- Now set appropriate Ada mode
13154 Ada_Version
:= Ada_2022
;
13155 Ada_Version_Explicit
:= Ada_2022
;
13156 Ada_Version_Pragma
:= N
;
13160 -------------------------------------
13161 -- Aggregate_Individually_Assign --
13162 -------------------------------------
13164 -- pragma Aggregate_Individually_Assign;
13166 when Pragma_Aggregate_Individually_Assign
=>
13168 Check_Arg_Count
(0);
13169 Check_Valid_Configuration_Pragma
;
13170 Aggregate_Individually_Assign
:= True;
13172 ----------------------
13173 -- All_Calls_Remote --
13174 ----------------------
13176 -- pragma All_Calls_Remote [(library_package_NAME)];
13178 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
13179 Lib_Entity
: Entity_Id
;
13182 Check_Ada_83_Warning
;
13183 Check_Valid_Library_Unit_Pragma
;
13185 -- If N was rewritten as a null statement there is nothing more
13188 if Nkind
(N
) = N_Null_Statement
then
13192 Lib_Entity
:= Find_Lib_Unit_Name
;
13194 -- A pragma that applies to a Ghost entity becomes Ghost for the
13195 -- purposes of legality checks and removal of ignored Ghost code.
13197 Mark_Ghost_Pragma
(N
, Lib_Entity
);
13199 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13201 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
13202 if not Is_Remote_Call_Interface
(Lib_Entity
) then
13203 Error_Pragma
("pragma% only apply to rci unit");
13205 -- Set flag for entity of the library unit
13208 Set_Has_All_Calls_Remote
(Lib_Entity
);
13211 end All_Calls_Remote
;
13213 ---------------------------
13214 -- Allow_Integer_Address --
13215 ---------------------------
13217 -- pragma Allow_Integer_Address;
13219 when Pragma_Allow_Integer_Address
=>
13221 Check_Valid_Configuration_Pragma
;
13222 Check_Arg_Count
(0);
13224 -- If Address is a private type, then set the flag to allow
13225 -- integer address values. If Address is not private, then this
13226 -- pragma has no purpose, so it is simply ignored. Not clear if
13227 -- there are any such targets now.
13229 if Opt
.Address_Is_Private
then
13230 Opt
.Allow_Integer_Address
:= True;
13233 -----------------------
13234 -- Always_Terminates --
13235 -----------------------
13237 -- pragma Always_Terminates [ (boolean_EXPRESSION) ];
13239 -- Characteristics:
13241 -- * Analysis - The annotation undergoes initial checks to verify
13242 -- the legal placement and context. Secondary checks preanalyze the
13245 -- Analyze_Always_Terminates_Cases_In_Decl_Part
13247 -- * Expansion - The annotation is expanded during the expansion of
13248 -- the related subprogram [body] contract as performed in:
13250 -- Expand_Subprogram_Contract
13252 -- * Template - The annotation utilizes the generic template of the
13253 -- related subprogram [body] when it is:
13255 -- aspect on subprogram declaration
13256 -- aspect on stand-alone subprogram body
13257 -- pragma on stand-alone subprogram body
13259 -- The annotation must prepare its own template when it is:
13261 -- pragma on subprogram declaration
13263 -- * Globals - Capture of global references must occur after full
13266 -- * Instance - The annotation is instantiated automatically when
13267 -- the related generic subprogram [body] is instantiated except for
13268 -- the "pragma on subprogram declaration" case. In that scenario
13269 -- the annotation must instantiate itself.
13271 when Pragma_Always_Terminates
=> Always_Terminates
: declare
13272 Spec_Id
: Entity_Id
;
13273 Subp_Decl
: Node_Id
;
13274 Subp_Spec
: Node_Id
;
13278 Check_No_Identifiers
;
13279 Check_At_Most_N_Arguments
(1);
13281 -- Ensure the proper placement of the pragma. Always_Terminates
13282 -- must be associated with a subprogram declaration or a body that
13286 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13288 -- Generic subprogram and package declaration
13290 if Nkind
(Subp_Decl
) in N_Generic_Declaration
then
13293 -- Package declaration
13295 elsif Nkind
(Subp_Decl
) = N_Package_Declaration
then
13298 -- Body acts as spec
13300 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13301 and then No
(Corresponding_Spec
(Subp_Decl
))
13305 -- Body stub acts as spec
13307 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13308 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13314 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13315 Subp_Spec
:= Specification
(Subp_Decl
);
13317 -- Pragma Always_Terminates is forbidden on null procedures,
13318 -- as this may lead to potential ambiguities in behavior
13319 -- when interface null procedures are involved. Also, it
13320 -- just wouldn't make sense, because null procedures always
13321 -- terminate anyway.
13323 if Nkind
(Subp_Spec
) = N_Procedure_Specification
13324 and then Null_Present
(Subp_Spec
)
13326 Error_Msg_N
(Fix_Error
13327 ("pragma % cannot apply to null procedure"), N
);
13333 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13340 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13342 -- In order to call Is_Function_With_Side_Effects, analyze pragma
13343 -- Side_Effects if present.
13345 Analyze_If_Present
(Pragma_Side_Effects
);
13347 -- Pragma Always_Terminates is not allowed on functions without
13350 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
13351 and then not Is_Function_With_Side_Effects
(Spec_Id
)
13353 Error_Msg_Code
:= GEC_Always_Terminates_On_Function
;
13355 if Ekind
(Spec_Id
) = E_Function
then
13356 Error_Msg_N
(Fix_Error
13357 ("pragma % cannot apply to function '[[]']"), N
);
13360 elsif Ekind
(Spec_Id
) = E_Generic_Function
then
13361 Error_Msg_N
(Fix_Error
13362 ("pragma % cannot apply to generic function '[[]']"), N
);
13367 -- Pragma Always_Terminates applied to packages doesn't allow any
13370 if Is_Package_Or_Generic_Package
(Spec_Id
)
13371 and then Arg_Count
/= 0
13373 Error_Msg_N
(Fix_Error
13374 ("pragma % applied to package cannot have arguments"), N
);
13378 -- A pragma that applies to a Ghost entity becomes Ghost for the
13379 -- purposes of legality checks and removal of ignored Ghost code.
13381 Mark_Ghost_Pragma
(N
, Spec_Id
);
13383 -- Chain the pragma on the contract for further processing by
13384 -- Analyze_Always_Terminates_In_Decl_Part.
13386 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13388 -- Fully analyze the pragma when it appears inside a subprogram
13389 -- body because it cannot benefit from forward references.
13391 if Nkind
(Subp_Decl
) in N_Subprogram_Body
13392 | N_Subprogram_Body_Stub
13394 -- The legality checks of pragma Always_Terminates are affected
13395 -- by the SPARK mode in effect and the volatility of the
13396 -- context. Analyze all pragmas in a specific order.
13398 Analyze_If_Present
(Pragma_SPARK_Mode
);
13399 Analyze_If_Present
(Pragma_Volatile_Function
);
13400 Analyze_Always_Terminates_In_Decl_Part
(N
);
13402 end Always_Terminates
;
13409 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13410 -- ARG ::= NAME | EXPRESSION
13412 -- The first two arguments are by convention intended to refer to an
13413 -- external tool and a tool-specific function. These arguments are
13416 when Pragma_Annotate | Pragma_GNAT_Annotate
=> Annotate
: declare
13421 --------------------------
13422 -- Inferred_String_Type --
13423 --------------------------
13425 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
;
13426 -- Infer the type to use for a string literal or a concatentation
13427 -- of operands whose types can be inferred. For such expressions,
13428 -- returns the "narrowest" of the three predefined string types
13429 -- that can represent the characters occurring in the expression.
13430 -- For other expressions, returns Empty.
13432 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
is
13434 case Nkind
(Expr
) is
13435 when N_String_Literal
=>
13436 if Has_Wide_Wide_Character
(Expr
) then
13437 return Standard_Wide_Wide_String
;
13438 elsif Has_Wide_Character
(Expr
) then
13439 return Standard_Wide_String
;
13441 return Standard_String
;
13444 when N_Op_Concat
=>
13446 L_Type
: constant Entity_Id
13447 := Preferred_String_Type
(Left_Opnd
(Expr
));
13448 R_Type
: constant Entity_Id
13449 := Preferred_String_Type
(Right_Opnd
(Expr
));
13451 Type_Table
: constant array (1 .. 4) of Entity_Id
13453 Standard_Wide_Wide_String
,
13454 Standard_Wide_String
,
13457 for Idx
in Type_Table
'Range loop
13458 if L_Type
= Type_Table
(Idx
) or
13459 R_Type
= Type_Table
(Idx
)
13461 return Type_Table
(Idx
);
13464 raise Program_Error
;
13470 end Preferred_String_Type
;
13473 Check_At_Least_N_Arguments
(1);
13475 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
13477 -- Determine whether the last argument is "Entity => local_NAME"
13478 -- and if it is, perform the required semantic checks. Remove the
13479 -- argument from further processing.
13481 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
13482 and then Chars
(Nam_Arg
) = Name_Entity
13484 Check_Arg_Is_Local_Name
(Nam_Arg
);
13485 Arg_Count
:= Arg_Count
- 1;
13487 -- A pragma that applies to a Ghost entity becomes Ghost for
13488 -- the purposes of legality checks and removal of ignored Ghost
13491 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
13492 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
13494 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
13498 -- Continue the processing with last argument removed for now
13500 Check_Arg_Is_Identifier
(Arg1
);
13501 Check_No_Identifiers
;
13504 -- The second parameter is optional, it is never analyzed
13509 -- Otherwise there is a second parameter
13512 -- The second parameter must be an identifier
13514 Check_Arg_Is_Identifier
(Arg2
);
13516 -- Process the remaining parameters (if any)
13518 Arg
:= Next
(Arg2
);
13519 while Present
(Arg
) loop
13520 Expr
:= Get_Pragma_Arg
(Arg
);
13523 if Is_Entity_Name
(Expr
) then
13526 -- For string literals and concatenations of string literals
13527 -- we assume Standard_String as the type, unless the string
13528 -- contains wide or wide_wide characters.
13530 elsif Present
(Preferred_String_Type
(Expr
)) then
13531 Resolve
(Expr
, Preferred_String_Type
(Expr
));
13533 elsif Is_Overloaded
(Expr
) then
13534 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13545 -------------------------------------------------
13546 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13547 -------------------------------------------------
13550 -- ( [Check => ] Boolean_EXPRESSION
13551 -- [, [Message =>] Static_String_EXPRESSION]);
13553 -- pragma Assert_And_Cut
13554 -- ( [Check => ] Boolean_EXPRESSION
13555 -- [, [Message =>] Static_String_EXPRESSION]);
13558 -- ( [Check => ] Boolean_EXPRESSION
13559 -- [, [Message =>] Static_String_EXPRESSION]);
13561 -- pragma Loop_Invariant
13562 -- ( [Check => ] Boolean_EXPRESSION
13563 -- [, [Message =>] Static_String_EXPRESSION]);
13566 | Pragma_Assert_And_Cut
13568 | Pragma_Loop_Invariant
13571 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13572 -- Determine whether expression Expr contains a Loop_Entry
13573 -- attribute reference.
13575 -------------------------
13576 -- Contains_Loop_Entry --
13577 -------------------------
13579 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13580 Has_Loop_Entry
: Boolean := False;
13582 function Process
(N
: Node_Id
) return Traverse_Result
;
13583 -- Process function for traversal to look for Loop_Entry
13589 function Process
(N
: Node_Id
) return Traverse_Result
is
13591 if Nkind
(N
) = N_Attribute_Reference
13592 and then Attribute_Name
(N
) = Name_Loop_Entry
13594 Has_Loop_Entry
:= True;
13601 procedure Traverse
is new Traverse_Proc
(Process
);
13603 -- Start of processing for Contains_Loop_Entry
13607 return Has_Loop_Entry
;
13608 end Contains_Loop_Entry
;
13613 New_Args
: List_Id
;
13615 -- Start of processing for Assert
13618 -- Assert is an Ada 2005 RM-defined pragma
13620 if Prag_Id
= Pragma_Assert
then
13623 -- The remaining ones are GNAT pragmas
13629 Check_At_Least_N_Arguments
(1);
13630 Check_At_Most_N_Arguments
(2);
13631 Check_Arg_Order
((Name_Check
, Name_Message
));
13632 Check_Optional_Identifier
(Arg1
, Name_Check
);
13633 Expr
:= Get_Pragma_Arg
(Arg1
);
13635 -- Special processing for Loop_Invariant, Loop_Variant or for
13636 -- other cases where a Loop_Entry attribute is present. If the
13637 -- assertion pragma contains attribute Loop_Entry, ensure that
13638 -- the related pragma is within a loop.
13640 if Prag_Id
= Pragma_Loop_Invariant
13641 or else Prag_Id
= Pragma_Loop_Variant
13642 or else Contains_Loop_Entry
(Expr
)
13644 Check_Loop_Pragma_Placement
;
13646 -- Perform preanalysis to deal with embedded Loop_Entry
13649 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13652 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13653 -- a corresponding Check pragma:
13655 -- pragma Check (name, condition [, msg]);
13657 -- Where name is the identifier matching the pragma name. So
13658 -- rewrite pragma in this manner, transfer the message argument
13659 -- if present, and analyze the result
13661 -- Note: When dealing with a semantically analyzed tree, the
13662 -- information that a Check node N corresponds to a source Assert,
13663 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13664 -- pragma kind of Original_Node(N).
13666 New_Args
:= New_List
(
13667 Make_Pragma_Argument_Association
(Loc
,
13668 Expression
=> Make_Identifier
(Loc
, Pname
)),
13669 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13670 Expression
=> Expr
));
13672 if Arg_Count
> 1 then
13673 Check_Optional_Identifier
(Arg2
, Name_Message
);
13675 -- Provide semantic annotations for optional argument, for
13676 -- ASIS use, before rewriting.
13677 -- Is this still needed???
13679 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13680 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13683 -- Rewrite as Check pragma
13687 Chars
=> Name_Check
,
13688 Pragma_Argument_Associations
=> New_Args
));
13693 ----------------------
13694 -- Assertion_Policy --
13695 ----------------------
13697 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13699 -- The following form is Ada 2012 only, but we allow it in all modes
13701 -- Pragma Assertion_Policy (
13702 -- ASSERTION_KIND => POLICY_IDENTIFIER
13703 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13705 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13707 -- RM_ASSERTION_KIND ::= Assert |
13708 -- Static_Predicate |
13709 -- Dynamic_Predicate |
13714 -- Type_Invariant |
13715 -- Type_Invariant'Class |
13716 -- Default_Initial_Condition
13718 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13720 -- Contract_Cases |
13723 -- Initial_Condition |
13724 -- Loop_Invariant |
13730 -- Statement_Assertions |
13731 -- Subprogram_Variant
13733 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13734 -- ID_ASSERTION_KIND list contains implementation-defined additions
13735 -- recognized by GNAT. The effect is to control the behavior of
13736 -- identically named aspects and pragmas, depending on the specified
13737 -- policy identifier:
13739 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13741 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13742 -- implementation-defined addition that results in totally ignoring
13743 -- the corresponding assertion. If Disable is specified, then the
13744 -- argument of the assertion is not even analyzed. This is useful
13745 -- when the aspect/pragma argument references entities in a with'ed
13746 -- package that is replaced by a dummy package in the final build.
13748 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13749 -- and Type_Invariant'Class were recognized by the parser and
13750 -- transformed into references to the special internal identifiers
13751 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13752 -- processing is required here.
13754 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13755 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13756 -- Converts the assertion policy 'Suppressible' to either Check or
13757 -- Ignore based on whether checks are suppressed via -gnatp.
13759 --------------------------
13760 -- Resolve_Suppressible --
13761 --------------------------
13763 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13764 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13768 -- Transform policy argument Suppressible into either Ignore or
13769 -- Check depending on whether checks are enabled or suppressed.
13771 if Chars
(Arg
) = Name_Suppressible
then
13772 if Suppress_Checks
then
13773 Nam
:= Name_Ignore
;
13778 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13780 end Resolve_Suppressible
;
13792 -- This can always appear as a configuration pragma
13794 if Is_Configuration_Pragma
then
13797 -- It can also appear in a declarative part or package spec in Ada
13798 -- 2012 mode. We allow this in other modes, but in that case we
13799 -- consider that we have an Ada 2012 pragma on our hands.
13802 Check_Is_In_Decl_Part_Or_Package_Spec
;
13806 -- One argument case with no identifier (first form above)
13809 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13810 or else Chars
(Arg1
) = No_Name
)
13812 Check_Arg_Is_One_Of
(Arg1
,
13813 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13815 Resolve_Suppressible
(Arg1
);
13817 -- Treat one argument Assertion_Policy as equivalent to:
13819 -- pragma Check_Policy (Assertion, policy)
13821 -- So rewrite pragma in that manner and link on to the chain
13822 -- of Check_Policy pragmas, marking the pragma as analyzed.
13824 Policy
:= Get_Pragma_Arg
(Arg1
);
13828 Chars
=> Name_Check_Policy
,
13829 Pragma_Argument_Associations
=> New_List
(
13830 Make_Pragma_Argument_Association
(Loc
,
13831 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13833 Make_Pragma_Argument_Association
(Loc
,
13835 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13838 -- Here if we have two or more arguments
13841 Check_At_Least_N_Arguments
(1);
13844 -- Loop through arguments
13847 while Present
(Arg
) loop
13848 LocP
:= Sloc
(Arg
);
13850 -- Kind must be specified
13852 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13853 or else Chars
(Arg
) = No_Name
13856 ("missing assertion kind for pragma%", Arg
);
13859 -- Check Kind and Policy have allowed forms
13861 Kind
:= Chars
(Arg
);
13862 Policy
:= Get_Pragma_Arg
(Arg
);
13864 if not Is_Valid_Assertion_Kind
(Kind
) then
13866 ("invalid assertion kind for pragma%", Arg
);
13869 Check_Arg_Is_One_Of
(Arg
,
13870 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13872 Resolve_Suppressible
(Arg
);
13874 if Kind
= Name_Ghost
then
13876 -- The Ghost policy must be either Check or Ignore
13877 -- (SPARK RM 6.9(6)).
13879 if Chars
(Policy
) not in Name_Check | Name_Ignore
then
13881 ("argument of pragma % Ghost must be Check or "
13882 & "Ignore", Policy
);
13885 -- Pragma Assertion_Policy specifying a Ghost policy
13886 -- cannot occur within a Ghost subprogram or package
13887 -- (SPARK RM 6.9(14)).
13889 if Ghost_Mode
> None
then
13891 ("pragma % cannot appear within ghost subprogram or "
13896 -- Rewrite the Assertion_Policy pragma as a series of
13897 -- Check_Policy pragmas of the form:
13899 -- Check_Policy (Kind, Policy);
13901 -- Note: the insertion of the pragmas cannot be done with
13902 -- Insert_Action because in the configuration case, there
13903 -- are no scopes on the scope stack and the mechanism will
13906 Insert_Before_And_Analyze
(N
,
13908 Chars
=> Name_Check_Policy
,
13909 Pragma_Argument_Associations
=> New_List
(
13910 Make_Pragma_Argument_Association
(LocP
,
13911 Expression
=> Make_Identifier
(LocP
, Kind
)),
13912 Make_Pragma_Argument_Association
(LocP
,
13913 Expression
=> Policy
))));
13918 -- Rewrite the Assertion_Policy pragma as null since we have
13919 -- now inserted all the equivalent Check pragmas.
13921 Rewrite
(N
, Make_Null_Statement
(Loc
));
13924 end Assertion_Policy
;
13926 ------------------------------
13927 -- Assume_No_Invalid_Values --
13928 ------------------------------
13930 -- pragma Assume_No_Invalid_Values (On | Off);
13932 when Pragma_Assume_No_Invalid_Values
=>
13934 Check_Valid_Configuration_Pragma
;
13935 Check_Arg_Count
(1);
13936 Check_No_Identifiers
;
13937 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13939 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13940 Assume_No_Invalid_Values
:= True;
13942 Assume_No_Invalid_Values
:= False;
13945 --------------------------
13946 -- Attribute_Definition --
13947 --------------------------
13949 -- pragma Attribute_Definition
13950 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13951 -- [Entity =>] LOCAL_NAME,
13952 -- [Expression =>] EXPRESSION | NAME);
13954 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13955 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13960 Check_Arg_Count
(3);
13961 Check_Optional_Identifier
(Arg1
, "attribute");
13962 Check_Optional_Identifier
(Arg2
, "entity");
13963 Check_Optional_Identifier
(Arg3
, "expression");
13965 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13966 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13970 Check_Arg_Is_Local_Name
(Arg2
);
13972 -- If the attribute is not recognized, then issue a warning (not
13973 -- an error), and ignore the pragma.
13975 Aname
:= Chars
(Attribute_Designator
);
13977 if not Is_Attribute_Name
(Aname
) then
13978 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13982 -- Otherwise, rewrite the pragma as an attribute definition clause
13985 Make_Attribute_Definition_Clause
(Loc
,
13986 Name
=> Get_Pragma_Arg
(Arg2
),
13988 Expression
=> Get_Pragma_Arg
(Arg3
)));
13990 end Attribute_Definition
;
13992 ------------------------------------------------------------------
13993 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13995 ------------------------------------------------------------------
13997 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13998 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13999 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
14000 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
14001 -- pragma No_Caching [ (boolean_EXPRESSION) ];
14003 when Pragma_Async_Readers
14004 | Pragma_Async_Writers
14005 | Pragma_Effective_Reads
14006 | Pragma_Effective_Writes
14007 | Pragma_No_Caching
14009 Async_Effective
: declare
14010 Obj_Or_Type_Decl
: Node_Id
;
14011 Obj_Or_Type_Id
: Entity_Id
;
14014 Check_No_Identifiers
;
14015 Check_At_Most_N_Arguments
(1);
14017 Obj_Or_Type_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14019 -- Pragma must apply to a object declaration or to a type
14020 -- declaration. Original_Node is necessary to account for
14021 -- untagged derived types that are rewritten as subtypes of
14022 -- their respective root types.
14024 if Nkind
(Obj_Or_Type_Decl
) /= N_Object_Declaration
14025 and then Nkind
(Original_Node
(Obj_Or_Type_Decl
)) not in
14026 N_Full_Type_Declaration |
14027 N_Private_Type_Declaration |
14028 N_Formal_Type_Declaration |
14029 N_Task_Type_Declaration |
14030 N_Protected_Type_Declaration
14035 Obj_Or_Type_Id
:= Defining_Entity
(Obj_Or_Type_Decl
);
14037 -- Perform minimal verification to ensure that the argument is at
14038 -- least an object or a type. Subsequent finer grained checks will
14039 -- be done at the end of the declarative region that contains the
14042 if Ekind
(Obj_Or_Type_Id
) in E_Constant | E_Variable
14043 or else Is_Type
(Obj_Or_Type_Id
)
14046 -- In the case of a type, pragma is a type-related
14047 -- representation item and so requires checks common to
14048 -- all type-related representation items.
14050 if Is_Type
(Obj_Or_Type_Id
)
14051 and then Rep_Item_Too_Late
(Obj_Or_Type_Id
, N
)
14056 -- A pragma that applies to a Ghost entity becomes Ghost for
14057 -- the purposes of legality checks and removal of ignored Ghost
14060 Mark_Ghost_Pragma
(N
, Obj_Or_Type_Id
);
14062 -- Chain the pragma on the contract for further processing by
14063 -- Analyze_External_Property_In_Decl_Part.
14065 Add_Contract_Item
(N
, Obj_Or_Type_Id
);
14067 -- Analyze the Boolean expression (if any)
14069 if Present
(Arg1
) then
14070 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14073 -- Otherwise the external property applies to a constant
14077 ("pragma % must apply to a volatile type or object");
14079 end Async_Effective
;
14085 -- pragma Asynchronous (LOCAL_NAME);
14087 when Pragma_Asynchronous
=> Asynchronous
: declare
14090 Formal
: Entity_Id
;
14095 procedure Process_Async_Pragma
;
14096 -- Common processing for procedure and access-to-procedure case
14098 --------------------------
14099 -- Process_Async_Pragma --
14100 --------------------------
14102 procedure Process_Async_Pragma
is
14105 Set_Is_Asynchronous
(Nm
);
14109 -- The formals should be of mode IN (RM E.4.1(6))
14112 while Present
(S
) loop
14113 Formal
:= Defining_Identifier
(S
);
14115 if Nkind
(Formal
) = N_Defining_Identifier
14116 and then Ekind
(Formal
) /= E_In_Parameter
14119 ("pragma% procedure can only have IN parameter",
14126 Set_Is_Asynchronous
(Nm
);
14127 end Process_Async_Pragma
;
14129 -- Start of processing for pragma Asynchronous
14132 Check_Ada_83_Warning
;
14133 Check_No_Identifiers
;
14134 Check_Arg_Count
(1);
14135 Check_Arg_Is_Local_Name
(Arg1
);
14137 if Debug_Flag_U
then
14141 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14142 Analyze
(Get_Pragma_Arg
(Arg1
));
14143 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
14145 -- A pragma that applies to a Ghost entity becomes Ghost for the
14146 -- purposes of legality checks and removal of ignored Ghost code.
14148 Mark_Ghost_Pragma
(N
, Nm
);
14150 if not Is_Remote_Call_Interface
(C_Ent
)
14151 and then not Is_Remote_Types
(C_Ent
)
14153 -- This pragma should only appear in an RCI or Remote Types
14154 -- unit (RM E.4.1(4)).
14157 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
14160 if Ekind
(Nm
) = E_Procedure
14161 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
14163 if not Is_Remote_Call_Interface
(Nm
) then
14165 ("pragma% cannot be applied on non-remote procedure",
14169 L
:= Parameter_Specifications
(Parent
(Nm
));
14170 Process_Async_Pragma
;
14173 elsif Ekind
(Nm
) = E_Function
then
14175 ("pragma% cannot be applied to function", Arg1
);
14177 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
14178 if Is_Record_Type
(Nm
) then
14180 -- A record type that is the Equivalent_Type for a remote
14181 -- access-to-subprogram type.
14183 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
14186 -- A non-expanded RAS type (distribution is not enabled)
14188 Decl
:= Declaration_Node
(Nm
);
14191 if Nkind
(Decl
) = N_Full_Type_Declaration
14192 and then Nkind
(Type_Definition
(Decl
)) =
14193 N_Access_Procedure_Definition
14195 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
14196 Process_Async_Pragma
;
14198 if Is_Asynchronous
(Nm
)
14199 and then Expander_Active
14200 and then Get_PCS_Name
/= Name_No_DSA
14202 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
14207 ("pragma% cannot reference access-to-function type",
14211 -- Only other possibility is access-to-class-wide type
14213 elsif Is_Access_Type
(Nm
)
14214 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
14216 Check_First_Subtype
(Arg1
);
14217 Set_Is_Asynchronous
(Nm
);
14218 if Expander_Active
then
14219 RACW_Type_Is_Asynchronous
(Nm
);
14223 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
14231 -- pragma Atomic (LOCAL_NAME);
14233 when Pragma_Atomic
=>
14234 Process_Atomic_Independent_Shared_Volatile
;
14236 -----------------------
14237 -- Atomic_Components --
14238 -----------------------
14240 -- pragma Atomic_Components (array_LOCAL_NAME);
14242 -- This processing is shared by Volatile_Components
14244 when Pragma_Atomic_Components
14245 | Pragma_Volatile_Components
14247 Atomic_Components
: declare
14253 Check_Ada_83_Warning
;
14254 Check_No_Identifiers
;
14255 Check_Arg_Count
(1);
14256 Check_Arg_Is_Local_Name
(Arg1
);
14257 E_Id
:= Get_Pragma_Arg
(Arg1
);
14259 if Etype
(E_Id
) = Any_Type
then
14263 E
:= Entity
(E_Id
);
14265 -- A pragma that applies to a Ghost entity becomes Ghost for the
14266 -- purposes of legality checks and removal of ignored Ghost code.
14268 Mark_Ghost_Pragma
(N
, E
);
14269 Check_Duplicate_Pragma
(E
);
14271 if Rep_Item_Too_Early
(E
, N
)
14273 Rep_Item_Too_Late
(E
, N
)
14278 D
:= Declaration_Node
(E
);
14280 if (Nkind
(D
) = N_Full_Type_Declaration
and then Is_Array_Type
(E
))
14282 (Nkind
(D
) = N_Object_Declaration
14283 and then Ekind
(E
) in E_Constant | E_Variable
14284 and then Nkind
(Object_Definition
(D
)) =
14285 N_Constrained_Array_Definition
)
14287 (Ada_Version
>= Ada_2022
14288 and then Nkind
(D
) = N_Formal_Type_Declaration
)
14290 -- The flag is set on the base type, or on the object
14292 if Nkind
(D
) = N_Full_Type_Declaration
then
14293 E
:= Base_Type
(E
);
14296 -- Atomic implies both Independent and Volatile
14298 if Prag_Id
= Pragma_Atomic_Components
then
14299 Set_Has_Atomic_Components
(E
);
14300 Set_Has_Independent_Components
(E
);
14303 Set_Has_Volatile_Components
(E
);
14306 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14308 end Atomic_Components
;
14310 --------------------
14311 -- Attach_Handler --
14312 --------------------
14314 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
14316 when Pragma_Attach_Handler
=>
14317 Check_Ada_83_Warning
;
14318 Check_No_Identifiers
;
14319 Check_Arg_Count
(2);
14321 if No_Run_Time_Mode
then
14322 Error_Msg_CRT
("Attach_Handler pragma", N
);
14324 Check_Interrupt_Or_Attach_Handler
;
14326 -- The expression that designates the attribute may depend on a
14327 -- discriminant, and is therefore a per-object expression, to
14328 -- be expanded in the init proc. If expansion is enabled, then
14329 -- perform semantic checks on a copy only.
14334 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
14337 -- In Relaxed_RM_Semantics mode, we allow any static
14338 -- integer value, for compatibility with other compilers.
14340 if Relaxed_RM_Semantics
14341 and then Nkind
(Parg2
) = N_Integer_Literal
14343 Typ
:= Standard_Integer
;
14345 Typ
:= RTE
(RE_Interrupt_ID
);
14348 if Expander_Active
then
14349 Temp
:= New_Copy_Tree
(Parg2
);
14350 Set_Parent
(Temp
, N
);
14351 Preanalyze_And_Resolve
(Temp
, Typ
);
14354 Resolve
(Parg2
, Typ
);
14358 Process_Interrupt_Or_Attach_Handler
;
14361 --------------------
14362 -- C_Pass_By_Copy --
14363 --------------------
14365 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
14367 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
14373 Check_Valid_Configuration_Pragma
;
14374 Check_Arg_Count
(1);
14375 Check_Optional_Identifier
(Arg1
, "max_size");
14377 Arg
:= Get_Pragma_Arg
(Arg1
);
14378 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
14380 Val
:= Expr_Value
(Arg
);
14384 ("maximum size for pragma% must be positive", Arg1
);
14386 elsif UI_Is_In_Int_Range
(Val
) then
14387 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
14389 -- If a giant value is given, Int'Last will do well enough.
14390 -- If sometime someone complains that a record larger than
14391 -- two gigabytes is not copied, we will worry about it then.
14394 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
14396 end C_Pass_By_Copy
;
14402 -- pragma Check ([Name =>] CHECK_KIND,
14403 -- [Check =>] Boolean_EXPRESSION
14404 -- [,[Message =>] String_EXPRESSION]);
14406 -- CHECK_KIND ::= IDENTIFIER |
14409 -- Invariant'Class |
14410 -- Type_Invariant'Class
14412 -- The identifiers Assertions and Statement_Assertions are not
14413 -- allowed, since they have special meaning for Check_Policy.
14415 -- WARNING: The code below manages Ghost regions. Return statements
14416 -- must be replaced by gotos which jump to the end of the code and
14417 -- restore the Ghost mode.
14419 when Pragma_Check
=> Check
: declare
14420 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
14421 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
14422 -- Save the Ghost-related attributes to restore on exit
14428 pragma Warnings
(Off
, Str
);
14431 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14432 -- the mode now to ensure that any nodes generated during analysis
14433 -- and expansion are marked as Ghost.
14435 Set_Ghost_Mode
(N
);
14438 Check_At_Least_N_Arguments
(2);
14439 Check_At_Most_N_Arguments
(3);
14440 Check_Optional_Identifier
(Arg1
, Name_Name
);
14441 Check_Optional_Identifier
(Arg2
, Name_Check
);
14443 if Arg_Count
= 3 then
14444 Check_Optional_Identifier
(Arg3
, Name_Message
);
14445 Str
:= Get_Pragma_Arg
(Arg3
);
14448 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
14449 Check_Arg_Is_Identifier
(Arg1
);
14450 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
14452 -- Check forbidden name Assertions or Statement_Assertions
14455 when Name_Assertions
=>
14457 ("""Assertions"" is not allowed as a check kind for "
14458 & "pragma%", Arg1
);
14460 when Name_Statement_Assertions
=>
14462 ("""Statement_Assertions"" is not allowed as a check kind "
14463 & "for pragma%", Arg1
);
14469 -- Check applicable policy. We skip this if Checked/Ignored status
14470 -- is already set (e.g. in the case of a pragma from an aspect).
14472 if Is_Checked
(N
) or else Is_Ignored
(N
) then
14475 -- For a non-source pragma that is a rewriting of another pragma,
14476 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14478 elsif Is_Rewrite_Substitution
(N
)
14479 and then Nkind
(Original_Node
(N
)) = N_Pragma
14481 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
14482 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
14484 -- Otherwise query the applicable policy at this point
14487 case Check_Kind
(Cname
) is
14488 when Name_Ignore
=>
14489 Set_Is_Ignored
(N
, True);
14490 Set_Is_Checked
(N
, False);
14493 Set_Is_Ignored
(N
, False);
14494 Set_Is_Checked
(N
, True);
14496 -- For disable, rewrite pragma as null statement and skip
14497 -- rest of the analysis of the pragma.
14499 when Name_Disable
=>
14500 Rewrite
(N
, Make_Null_Statement
(Loc
));
14504 -- No other possibilities
14507 raise Program_Error
;
14511 -- If check kind was not Disable, then continue pragma analysis
14513 Expr
:= Get_Pragma_Arg
(Arg2
);
14515 -- Mark the pragma (or, if rewritten from an aspect, the original
14516 -- aspect) as enabled. Nothing to do for an internally generated
14517 -- check for a dynamic predicate.
14520 and then not Split_PPC
(N
)
14521 and then Cname
/= Name_Dynamic_Predicate
14523 Set_SCO_Pragma_Enabled
(Loc
);
14526 -- Deal with analyzing the string argument. If checks are not
14527 -- on we don't want any expansion (since such expansion would
14528 -- not get properly deleted) but we do want to analyze (to get
14529 -- proper references). The Preanalyze_And_Resolve routine does
14530 -- just what we want. Ditto if pragma is active, because it will
14531 -- be rewritten as an if-statement whose analysis will complete
14532 -- analysis and expansion of the string message. This makes a
14533 -- difference in the unusual case where the expression for the
14534 -- string may have a side effect, such as raising an exception.
14535 -- This is mandated by RM 11.4.2, which specifies that the string
14536 -- expression is only evaluated if the check fails and
14537 -- Assertion_Error is to be raised.
14539 if Arg_Count
= 3 then
14540 Preanalyze_And_Resolve
(Str
, Standard_String
);
14543 -- Now you might think we could just do the same with the Boolean
14544 -- expression if checks are off (and expansion is on) and then
14545 -- rewrite the check as a null statement. This would work but we
14546 -- would lose the useful warnings about an assertion being bound
14547 -- to fail even if assertions are turned off.
14549 -- So instead we wrap the boolean expression in an if statement
14550 -- that looks like:
14552 -- if False and then condition then
14556 -- The reason we do this rewriting during semantic analysis rather
14557 -- than as part of normal expansion is that we cannot analyze and
14558 -- expand the code for the boolean expression directly, or it may
14559 -- cause insertion of actions that would escape the attempt to
14560 -- suppress the check code.
14562 -- Note that the Sloc for the if statement corresponds to the
14563 -- argument condition, not the pragma itself. The reason for
14564 -- this is that we may generate a warning if the condition is
14565 -- False at compile time, and we do not want to delete this
14566 -- warning when we delete the if statement.
14568 if Expander_Active
and Is_Ignored
(N
) then
14569 Eloc
:= Sloc
(Expr
);
14572 Make_If_Statement
(Eloc
,
14574 Make_And_Then
(Eloc
,
14575 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14576 Right_Opnd
=> Expr
),
14577 Then_Statements
=> New_List
(
14578 Make_Null_Statement
(Eloc
))));
14580 -- Now go ahead and analyze the if statement
14582 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14584 -- One rather special treatment. If we are now in Eliminated
14585 -- overflow mode, then suppress overflow checking since we do
14586 -- not want to drag in the bignum stuff if we are in Ignore
14587 -- mode anyway. This is particularly important if we are using
14588 -- a configurable run time that does not support bignum ops.
14590 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14592 Svo
: constant Boolean :=
14593 Scope_Suppress
.Suppress
(Overflow_Check
);
14595 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14596 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14598 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14599 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14602 -- Not that special case
14608 -- All done with this check
14610 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14612 -- Check is active or expansion not active. In these cases we can
14613 -- just go ahead and analyze the boolean with no worries.
14616 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14617 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14618 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14621 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14624 --------------------------
14625 -- Check_Float_Overflow --
14626 --------------------------
14628 -- pragma Check_Float_Overflow;
14630 when Pragma_Check_Float_Overflow
=>
14632 Check_Valid_Configuration_Pragma
;
14633 Check_Arg_Count
(0);
14634 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14640 -- pragma Check_Name (check_IDENTIFIER);
14642 when Pragma_Check_Name
=>
14644 Check_No_Identifiers
;
14645 Check_Valid_Configuration_Pragma
;
14646 Check_Arg_Count
(1);
14647 Check_Arg_Is_Identifier
(Arg1
);
14650 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14653 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14654 if Check_Names
.Table
(J
) = Nam
then
14659 Check_Names
.Append
(Nam
);
14666 -- This is the old style syntax, which is still allowed in all modes:
14668 -- pragma Check_Policy ([Name =>] CHECK_KIND
14669 -- [Policy =>] POLICY_IDENTIFIER);
14671 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14673 -- CHECK_KIND ::= IDENTIFIER |
14676 -- Type_Invariant'Class |
14679 -- This is the new style syntax, compatible with Assertion_Policy
14680 -- and also allowed in all modes.
14682 -- Pragma Check_Policy (
14683 -- CHECK_KIND => POLICY_IDENTIFIER
14684 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14686 -- Note: the identifiers Name and Policy are not allowed as
14687 -- Check_Kind values. This avoids ambiguities between the old and
14688 -- new form syntax.
14690 when Pragma_Check_Policy
=> Check_Policy
: declare
14695 Check_At_Least_N_Arguments
(1);
14697 -- A Check_Policy pragma can appear either as a configuration
14698 -- pragma, or in a declarative part or a package spec (see RM
14699 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14700 -- followed for Check_Policy).
14702 if not Is_Configuration_Pragma
then
14703 Check_Is_In_Decl_Part_Or_Package_Spec
;
14706 -- Figure out if we have the old or new syntax. We have the
14707 -- old syntax if the first argument has no identifier, or the
14708 -- identifier is Name.
14710 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14711 or else Chars
(Arg1
) in No_Name | Name_Name
14715 Check_Arg_Count
(2);
14716 Check_Optional_Identifier
(Arg1
, Name_Name
);
14717 Kind
:= Get_Pragma_Arg
(Arg1
);
14718 Rewrite_Assertion_Kind
(Kind
,
14719 From_Policy
=> Comes_From_Source
(N
));
14720 Check_Arg_Is_Identifier
(Arg1
);
14722 -- Check forbidden check kind
14724 if Chars
(Kind
) in Name_Name | Name_Policy
then
14725 Error_Msg_Name_2
:= Chars
(Kind
);
14727 ("pragma% does not allow% as check name", Arg1
);
14732 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14733 Check_Arg_Is_One_Of
14735 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14737 -- And chain pragma on the Check_Policy_List for search
14739 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14740 Opt
.Check_Policy_List
:= N
;
14742 -- For the new syntax, what we do is to convert each argument to
14743 -- an old syntax equivalent. We do that because we want to chain
14744 -- old style Check_Policy pragmas for the search (we don't want
14745 -- to have to deal with multiple arguments in the search).
14756 while Present
(Arg
) loop
14757 LocP
:= Sloc
(Arg
);
14758 Argx
:= Get_Pragma_Arg
(Arg
);
14760 -- Kind must be specified
14762 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14763 or else Chars
(Arg
) = No_Name
14766 ("missing assertion kind for pragma%", Arg
);
14769 -- Construct equivalent old form syntax Check_Policy
14770 -- pragma and insert it to get remaining checks.
14774 Chars
=> Name_Check_Policy
,
14775 Pragma_Argument_Associations
=> New_List
(
14776 Make_Pragma_Argument_Association
(LocP
,
14778 Make_Identifier
(LocP
, Chars
(Arg
))),
14779 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14780 Expression
=> Argx
)));
14784 -- For a configuration pragma, insert old form in
14785 -- the corresponding file.
14787 if Is_Configuration_Pragma
then
14788 Insert_After
(N
, New_P
);
14792 Insert_Action
(N
, New_P
);
14796 -- Rewrite original Check_Policy pragma to null, since we
14797 -- have converted it into a series of old syntax pragmas.
14799 Rewrite
(N
, Make_Null_Statement
(Loc
));
14809 -- pragma Comment (static_string_EXPRESSION)
14811 -- Processing for pragma Comment shares the circuitry for pragma
14812 -- Ident. The only differences are that Ident enforces a limit of 31
14813 -- characters on its argument, and also enforces limitations on
14814 -- placement for DEC compatibility. Pragma Comment shares neither of
14815 -- these restrictions.
14817 -------------------
14818 -- Common_Object --
14819 -------------------
14821 -- pragma Common_Object (
14822 -- [Internal =>] LOCAL_NAME
14823 -- [, [External =>] EXTERNAL_SYMBOL]
14824 -- [, [Size =>] EXTERNAL_SYMBOL]);
14826 -- Processing for this pragma is shared with Psect_Object
14828 ----------------------------------------------
14829 -- Compile_Time_Error, Compile_Time_Warning --
14830 ----------------------------------------------
14832 -- pragma Compile_Time_Error
14833 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14835 -- pragma Compile_Time_Warning
14836 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14838 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning
=>
14841 Process_Compile_Time_Warning_Or_Error
;
14843 -----------------------------
14844 -- Complete_Representation --
14845 -----------------------------
14847 -- pragma Complete_Representation;
14849 when Pragma_Complete_Representation
=>
14851 Check_Arg_Count
(0);
14853 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14855 ("pragma & must appear within record representation clause");
14858 ----------------------------
14859 -- Complex_Representation --
14860 ----------------------------
14862 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14864 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14871 Check_Arg_Count
(1);
14872 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14873 Check_Arg_Is_Local_Name
(Arg1
);
14874 E_Id
:= Get_Pragma_Arg
(Arg1
);
14876 if Etype
(E_Id
) = Any_Type
then
14880 E
:= Entity
(E_Id
);
14882 if not Is_Record_Type
(E
) then
14884 ("argument for pragma% must be record type", Arg1
);
14887 Ent
:= First_Entity
(E
);
14890 or else No
(Next_Entity
(Ent
))
14891 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14892 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14893 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14896 ("record for pragma% must have two fields of the same "
14897 & "floating-point type", Arg1
);
14900 Set_Has_Complex_Representation
(Base_Type
(E
));
14902 -- We need to treat the type has having a non-standard
14903 -- representation, for back-end purposes, even though in
14904 -- general a complex will have the default representation
14905 -- of a record with two real components.
14907 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14909 end Complex_Representation
;
14911 -------------------------
14912 -- Component_Alignment --
14913 -------------------------
14915 -- pragma Component_Alignment (
14916 -- [Form =>] ALIGNMENT_CHOICE
14917 -- [, [Name =>] type_LOCAL_NAME]);
14919 -- ALIGNMENT_CHOICE ::=
14921 -- | Component_Size_4
14925 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14926 Args
: Args_List
(1 .. 2);
14927 Names
: constant Name_List
(1 .. 2) := (
14931 Form
: Node_Id
renames Args
(1);
14932 Name
: Node_Id
renames Args
(2);
14934 Atype
: Component_Alignment_Kind
;
14939 Gather_Associations
(Names
, Args
);
14942 Error_Pragma
("missing Form argument for pragma%");
14945 Check_Arg_Is_Identifier
(Form
);
14947 -- Get proper alignment, note that Default = Component_Size on all
14948 -- machines we have so far, and we want to set this value rather
14949 -- than the default value to indicate that it has been explicitly
14950 -- set (and thus will not get overridden by the default component
14951 -- alignment for the current scope)
14953 if Chars
(Form
) = Name_Component_Size
then
14954 Atype
:= Calign_Component_Size
;
14956 elsif Chars
(Form
) = Name_Component_Size_4
then
14957 Atype
:= Calign_Component_Size_4
;
14959 elsif Chars
(Form
) = Name_Default
then
14960 Atype
:= Calign_Component_Size
;
14962 elsif Chars
(Form
) = Name_Storage_Unit
then
14963 Atype
:= Calign_Storage_Unit
;
14967 ("invalid Form parameter for pragma%", Form
);
14970 -- The pragma appears in a configuration file
14972 if No
(Parent
(N
)) then
14973 Check_Valid_Configuration_Pragma
;
14975 -- Capture the component alignment in a global variable when
14976 -- the pragma appears in a configuration file. Note that the
14977 -- scope stack is empty at this point and cannot be used to
14978 -- store the alignment value.
14980 Configuration_Component_Alignment
:= Atype
;
14982 -- Case with no name, supplied, affects scope table entry
14984 elsif No
(Name
) then
14986 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14988 -- Case of name supplied
14991 Check_Arg_Is_Local_Name
(Name
);
14993 Typ
:= Entity
(Name
);
14996 or else Rep_Item_Too_Early
(Typ
, N
)
15000 Typ
:= Underlying_Type
(Typ
);
15003 if not Is_Record_Type
(Typ
)
15004 and then not Is_Array_Type
(Typ
)
15007 ("Name parameter of pragma% must identify record or "
15008 & "array type", Name
);
15011 -- An explicit Component_Alignment pragma overrides an
15012 -- implicit pragma Pack, but not an explicit one.
15014 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
15015 Set_Is_Packed
(Base_Type
(Typ
), False);
15016 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
15019 end Component_AlignmentP
;
15021 --------------------------------
15022 -- Constant_After_Elaboration --
15023 --------------------------------
15025 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
15027 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
15029 Obj_Decl
: Node_Id
;
15030 Obj_Id
: Entity_Id
;
15034 Check_No_Identifiers
;
15035 Check_At_Most_N_Arguments
(1);
15037 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
15039 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
15043 Obj_Id
:= Defining_Entity
(Obj_Decl
);
15045 -- The object declaration must be a library-level variable which
15046 -- is either explicitly initialized or obtains a value during the
15047 -- elaboration of a package body (SPARK RM 3.3.1).
15049 if Ekind
(Obj_Id
) = E_Variable
then
15050 if not Is_Library_Level_Entity
(Obj_Id
) then
15052 ("pragma % must apply to a library level variable");
15055 -- Otherwise the pragma applies to a constant, which is illegal
15058 Error_Pragma
("pragma % must apply to a variable declaration");
15061 -- A pragma that applies to a Ghost entity becomes Ghost for the
15062 -- purposes of legality checks and removal of ignored Ghost code.
15064 Mark_Ghost_Pragma
(N
, Obj_Id
);
15066 -- Chain the pragma on the contract for completeness
15068 Add_Contract_Item
(N
, Obj_Id
);
15070 -- Analyze the Boolean expression (if any)
15072 if Present
(Arg1
) then
15073 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
15075 end Constant_After_Elaboration
;
15077 --------------------
15078 -- Contract_Cases --
15079 --------------------
15081 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
15083 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
15085 -- CASE_GUARD ::= boolean_EXPRESSION | others
15087 -- CONSEQUENCE ::= boolean_EXPRESSION
15089 -- Characteristics:
15091 -- * Analysis - The annotation undergoes initial checks to verify
15092 -- the legal placement and context. Secondary checks preanalyze the
15095 -- Analyze_Contract_Cases_In_Decl_Part
15097 -- * Expansion - The annotation is expanded during the expansion of
15098 -- the related subprogram [body] contract as performed in:
15100 -- Expand_Subprogram_Contract
15102 -- * Template - The annotation utilizes the generic template of the
15103 -- related subprogram [body] when it is:
15105 -- aspect on subprogram declaration
15106 -- aspect on stand-alone subprogram body
15107 -- pragma on stand-alone subprogram body
15109 -- The annotation must prepare its own template when it is:
15111 -- pragma on subprogram declaration
15113 -- * Globals - Capture of global references must occur after full
15116 -- * Instance - The annotation is instantiated automatically when
15117 -- the related generic subprogram [body] is instantiated except for
15118 -- the "pragma on subprogram declaration" case. In that scenario
15119 -- the annotation must instantiate itself.
15121 when Pragma_Contract_Cases
=> Contract_Cases
: declare
15122 Spec_Id
: Entity_Id
;
15123 Subp_Decl
: Node_Id
;
15124 Subp_Spec
: Node_Id
;
15128 Check_No_Identifiers
;
15129 Check_Arg_Count
(1);
15131 -- Ensure the proper placement of the pragma. Contract_Cases must
15132 -- be associated with a subprogram declaration or a body that acts
15136 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15140 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
15143 -- Generic subprogram
15145 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15148 -- Body acts as spec
15150 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15151 and then No
(Corresponding_Spec
(Subp_Decl
))
15155 -- Body stub acts as spec
15157 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15158 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15164 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15165 Subp_Spec
:= Specification
(Subp_Decl
);
15167 -- Pragma Contract_Cases is forbidden on null procedures, as
15168 -- this may lead to potential ambiguities in behavior when
15169 -- interface null procedures are involved.
15171 if Nkind
(Subp_Spec
) = N_Procedure_Specification
15172 and then Null_Present
(Subp_Spec
)
15174 Error_Msg_N
(Fix_Error
15175 ("pragma % cannot apply to null procedure"), N
);
15183 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15185 -- A pragma that applies to a Ghost entity becomes Ghost for the
15186 -- purposes of legality checks and removal of ignored Ghost code.
15188 Mark_Ghost_Pragma
(N
, Spec_Id
);
15189 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
15191 -- Chain the pragma on the contract for further processing by
15192 -- Analyze_Contract_Cases_In_Decl_Part.
15194 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15196 -- Fully analyze the pragma when it appears inside an entry
15197 -- or subprogram body because it cannot benefit from forward
15200 if Nkind
(Subp_Decl
) in N_Entry_Body
15201 | N_Subprogram_Body
15202 | N_Subprogram_Body_Stub
15204 -- The legality checks of pragma Contract_Cases are affected by
15205 -- the SPARK mode in effect and the volatility of the context.
15206 -- Analyze all pragmas in a specific order.
15208 Analyze_If_Present
(Pragma_SPARK_Mode
);
15209 Analyze_If_Present
(Pragma_Volatile_Function
);
15210 Analyze_Contract_Cases_In_Decl_Part
(N
);
15212 end Contract_Cases
;
15218 -- pragma Controlled (first_subtype_LOCAL_NAME);
15220 when Pragma_Controlled
=> Controlled
: declare
15224 Check_No_Identifiers
;
15225 Check_Arg_Count
(1);
15226 Check_Arg_Is_Local_Name
(Arg1
);
15227 Arg
:= Get_Pragma_Arg
(Arg1
);
15229 if not Is_Entity_Name
(Arg
)
15230 or else not Is_Access_Type
(Entity
(Arg
))
15232 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
15234 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
15242 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
15243 -- [Entity =>] LOCAL_NAME);
15245 when Pragma_Convention
=> Convention
: declare
15248 pragma Warnings
(Off
, C
);
15249 pragma Warnings
(Off
, E
);
15252 Check_Arg_Order
((Name_Convention
, Name_Entity
));
15253 Check_Ada_83_Warning
;
15254 Check_Arg_Count
(2);
15255 Process_Convention
(C
, E
);
15257 -- A pragma that applies to a Ghost entity becomes Ghost for the
15258 -- purposes of legality checks and removal of ignored Ghost code.
15260 Mark_Ghost_Pragma
(N
, E
);
15263 ---------------------------
15264 -- Convention_Identifier --
15265 ---------------------------
15267 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
15268 -- [Convention =>] convention_IDENTIFIER);
15270 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
15276 Check_Arg_Order
((Name_Name
, Name_Convention
));
15277 Check_Arg_Count
(2);
15278 Check_Optional_Identifier
(Arg1
, Name_Name
);
15279 Check_Optional_Identifier
(Arg2
, Name_Convention
);
15280 Check_Arg_Is_Identifier
(Arg1
);
15281 Check_Arg_Is_Identifier
(Arg2
);
15282 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
15283 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
15285 if Is_Convention_Name
(Cname
) then
15286 Record_Convention_Identifier
15287 (Idnam
, Get_Convention_Id
(Cname
));
15290 ("second arg for % pragma must be convention", Arg2
);
15292 end Convention_Identifier
;
15298 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
15300 when Pragma_CPP_Class
=>
15303 if Warn_On_Obsolescent_Feature
then
15305 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
15306 & "effect; replace it by pragma import?j?", N
);
15309 Check_Arg_Count
(1);
15313 Chars
=> Name_Import
,
15314 Pragma_Argument_Associations
=> New_List
(
15315 Make_Pragma_Argument_Association
(Loc
,
15316 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
15317 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
15320 ---------------------
15321 -- CPP_Constructor --
15322 ---------------------
15324 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
15325 -- [, [External_Name =>] static_string_EXPRESSION ]
15326 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15328 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
15330 Def_Id
: Entity_Id
;
15331 Tag_Typ
: Entity_Id
;
15335 Check_At_Least_N_Arguments
(1);
15336 Check_At_Most_N_Arguments
(3);
15337 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15338 Check_Arg_Is_Local_Name
(Arg1
);
15340 Id
:= Get_Pragma_Arg
(Arg1
);
15341 Find_Program_Unit_Name
(Id
);
15343 -- If we did not find the name, we are done
15345 if Etype
(Id
) = Any_Type
then
15349 Def_Id
:= Entity
(Id
);
15351 -- Check if already defined as constructor
15353 if Is_Constructor
(Def_Id
) then
15355 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
15359 if Ekind
(Def_Id
) = E_Function
15360 and then (Is_CPP_Class
(Etype
(Def_Id
))
15361 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
15363 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
15365 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
15367 ("'C'P'P constructor must be defined in the scope of "
15368 & "its returned type", Arg1
);
15371 if Arg_Count
>= 2 then
15372 Set_Imported
(Def_Id
);
15373 Set_Is_Public
(Def_Id
);
15374 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
15377 Set_Has_Completion
(Def_Id
);
15378 Set_Is_Constructor
(Def_Id
);
15379 Set_Convention
(Def_Id
, Convention_CPP
);
15381 -- Imported C++ constructors are not dispatching primitives
15382 -- because in C++ they don't have a dispatch table slot.
15383 -- However, in Ada the constructor has the profile of a
15384 -- function that returns a tagged type and therefore it has
15385 -- been treated as a primitive operation during semantic
15386 -- analysis. We now remove it from the list of primitive
15387 -- operations of the type.
15389 if Is_Tagged_Type
(Etype
(Def_Id
))
15390 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
15391 and then Is_Dispatching_Operation
(Def_Id
)
15393 Tag_Typ
:= Etype
(Def_Id
);
15395 Remove
(Primitive_Operations
(Tag_Typ
), Def_Id
);
15396 Set_Is_Dispatching_Operation
(Def_Id
, False);
15399 -- For backward compatibility, if the constructor returns a
15400 -- class wide type, and we internally change the return type to
15401 -- the corresponding root type.
15403 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
15404 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
15408 ("pragma% requires function returning a 'C'P'P_Class type",
15411 end CPP_Constructor
;
15417 when Pragma_CPP_Virtual
=>
15420 if Warn_On_Obsolescent_Feature
then
15422 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15430 when Pragma_CUDA_Device
=> CUDA_Device
: declare
15431 Arg_Node
: Node_Id
;
15432 Device_Entity
: Entity_Id
;
15435 Check_Arg_Count
(1);
15436 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15438 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15439 Device_Entity
:= Entity
(Arg_Node
);
15441 if Ekind
(Device_Entity
) in E_Variable
15446 Add_CUDA_Device_Entity
15447 (Package_Specification_Of_Scope
(Scope
(Device_Entity
)),
15451 Error_Msg_NE
("& must be constant, variable or subprogram",
15462 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
15466 -- [, EXPRESSION]]);
15468 when Pragma_CUDA_Execute
=> CUDA_Execute
: declare
15470 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean;
15471 -- Returns True if N is an acceptable argument for CUDA_Execute,
15472 -- False otherwise.
15474 ------------------------
15475 -- Is_Acceptable_Dim3 --
15476 ------------------------
15478 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean is
15481 if Is_RTE
(Etype
(N
), RE_Dim3
)
15482 or else Is_Integer_Type
(Etype
(N
))
15487 if Nkind
(N
) = N_Aggregate
15488 and then not Null_Record_Present
(N
)
15489 and then No
(Component_Associations
(N
))
15490 and then List_Length
(Expressions
(N
)) = 3
15492 Expr
:= First
(Expressions
(N
));
15493 while Present
(Expr
) loop
15494 Analyze_And_Resolve
(Expr
, Any_Integer
);
15501 end Is_Acceptable_Dim3
;
15505 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg3
);
15506 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
15507 Kernel_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15508 Shared_Memory
: Node_Id
;
15511 -- Start of processing for CUDA_Execute
15515 Check_At_Least_N_Arguments
(3);
15516 Check_At_Most_N_Arguments
(5);
15518 Analyze_And_Resolve
(Kernel_Call
);
15519 if Nkind
(Kernel_Call
) /= N_Function_Call
15520 or else Etype
(Kernel_Call
) /= Standard_Void_Type
15522 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
15523 -- GNAT sees Kernel_Call as an N_Function_Call since
15524 -- Kernel_Call "looks" like an expression. However, only
15525 -- procedures can be kernels, so to make things easier for the
15526 -- user the error message complains about Kernel_Call not being
15527 -- a procedure call.
15529 Error_Msg_N
("first argument of & must be a procedure call", N
);
15532 Analyze
(Grid_Dimensions
);
15533 if not Is_Acceptable_Dim3
(Grid_Dimensions
) then
15535 ("second argument of & must be an Integer, Dim3 or aggregate "
15536 & "containing 3 Integers", N
);
15539 Analyze
(Block_Dimensions
);
15540 if not Is_Acceptable_Dim3
(Block_Dimensions
) then
15542 ("third argument of & must be an Integer, Dim3 or aggregate "
15543 & "containing 3 Integers", N
);
15546 if Present
(Arg4
) then
15547 Shared_Memory
:= Get_Pragma_Arg
(Arg4
);
15548 Analyze_And_Resolve
(Shared_Memory
, Any_Integer
);
15550 if Present
(Arg5
) then
15551 Stream
:= Get_Pragma_Arg
(Arg5
);
15552 Analyze_And_Resolve
(Stream
, RTE
(RE_Stream_T
));
15561 -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
15563 when Pragma_CUDA_Global
=> CUDA_Global
: declare
15564 Arg_Node
: Node_Id
;
15565 Kernel_Proc
: Entity_Id
;
15566 Pack_Id
: Entity_Id
;
15569 Check_Arg_Count
(1);
15570 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15571 Check_Arg_Is_Local_Name
(Arg1
);
15573 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15574 Analyze
(Arg_Node
);
15576 Kernel_Proc
:= Entity
(Arg_Node
);
15577 Pack_Id
:= Scope
(Kernel_Proc
);
15579 if Ekind
(Kernel_Proc
) /= E_Procedure
then
15580 Error_Msg_NE
("& must be a procedure", N
, Kernel_Proc
);
15582 elsif Ekind
(Pack_Id
) /= E_Package
15583 or else not Is_Library_Level_Entity
(Pack_Id
)
15586 ("& must reside in a library-level package", N
, Kernel_Proc
);
15589 Set_Is_CUDA_Kernel
(Kernel_Proc
);
15590 Add_CUDA_Kernel
(Pack_Id
, Kernel_Proc
);
15598 when Pragma_CPP_Vtable
=>
15601 if Warn_On_Obsolescent_Feature
then
15603 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15611 -- pragma CPU (EXPRESSION);
15613 when Pragma_CPU
=> CPU
: declare
15614 P
: constant Node_Id
:= Parent
(N
);
15620 Check_No_Identifiers
;
15621 Check_Arg_Count
(1);
15622 Arg
:= Get_Pragma_Arg
(Arg1
);
15626 if Nkind
(P
) = N_Subprogram_Body
then
15627 Check_In_Main_Program
;
15629 Analyze_And_Resolve
(Arg
, Any_Integer
);
15631 Ent
:= Defining_Unit_Name
(Specification
(P
));
15633 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15634 Ent
:= Defining_Identifier
(Ent
);
15639 if not Is_OK_Static_Expression
(Arg
) then
15640 Flag_Non_Static_Expr
15641 ("main subprogram affinity is not static!", Arg
);
15644 -- If constraint error, then we already signalled an error
15646 elsif Raises_Constraint_Error
(Arg
) then
15649 -- Otherwise check in range
15653 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15654 -- This is the entity System.Multiprocessors.CPU_Range;
15656 Val
: constant Uint
:= Expr_Value
(Arg
);
15659 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15661 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15664 ("main subprogram CPU is out of range", Arg1
);
15670 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15674 elsif Nkind
(P
) = N_Task_Definition
then
15675 Ent
:= Defining_Identifier
(Parent
(P
));
15677 -- The expression must be analyzed in the special manner
15678 -- described in "Handling of Default and Per-Object
15679 -- Expressions" in sem.ads.
15681 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15683 -- See comment in Sem_Ch13 about the following restrictions
15685 if Is_OK_Static_Expression
(Arg
) then
15686 if Expr_Value
(Arg
) = Uint_0
then
15687 Check_Restriction
(No_Tasks_Unassigned_To_CPU
, N
);
15690 Check_Restriction
(No_Dynamic_CPU_Assignment
, N
);
15693 -- Anything else is incorrect
15699 -- Check duplicate pragma before we chain the pragma in the Rep
15700 -- Item chain of Ent.
15702 Check_Duplicate_Pragma
(Ent
);
15703 Record_Rep_Item
(Ent
, N
);
15706 --------------------
15707 -- Deadline_Floor --
15708 --------------------
15710 -- pragma Deadline_Floor (time_span_EXPRESSION);
15712 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15713 P
: constant Node_Id
:= Parent
(N
);
15719 Check_No_Identifiers
;
15720 Check_Arg_Count
(1);
15722 Arg
:= Get_Pragma_Arg
(Arg1
);
15724 -- The expression must be analyzed in the special manner described
15725 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15727 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15729 -- Only protected types allowed
15731 if Nkind
(P
) /= N_Protected_Definition
then
15735 Ent
:= Defining_Identifier
(Parent
(P
));
15737 -- Check duplicate pragma before we chain the pragma in the Rep
15738 -- Item chain of Ent.
15740 Check_Duplicate_Pragma
(Ent
);
15741 Record_Rep_Item
(Ent
, N
);
15743 end Deadline_Floor
;
15749 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15751 when Pragma_Debug
=> Debug
: declare
15758 -- The condition for executing the call is that the expander
15759 -- is active and that we are not ignoring this debug pragma.
15764 (Expander_Active
and then not Is_Ignored
(N
)),
15767 if not Is_Ignored
(N
) then
15768 Set_SCO_Pragma_Enabled
(Loc
);
15771 if Arg_Count
= 2 then
15773 Make_And_Then
(Loc
,
15774 Left_Opnd
=> Relocate_Node
(Cond
),
15775 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15776 Call
:= Get_Pragma_Arg
(Arg2
);
15778 Call
:= Get_Pragma_Arg
(Arg1
);
15781 if Nkind
(Call
) in N_Expanded_Name
15784 | N_Indexed_Component
15785 | N_Selected_Component
15787 -- If this pragma Debug comes from source, its argument was
15788 -- parsed as a name form (which is syntactically identical).
15789 -- In a generic context a parameterless call will be left as
15790 -- an expanded name (if global) or selected_component if local.
15791 -- Change it to a procedure call statement now.
15793 Change_Name_To_Procedure_Call_Statement
(Call
);
15795 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15797 -- Already in the form of a procedure call statement: nothing
15798 -- to do (could happen in case of an internally generated
15804 -- All other cases: diagnose error
15807 ("argument of pragma ""Debug"" is not procedure call", Call
);
15811 -- Rewrite into a conditional with an appropriate condition. We
15812 -- wrap the procedure call in a block so that overhead from e.g.
15813 -- use of the secondary stack does not generate execution overhead
15814 -- for suppressed conditions.
15816 -- Normally the analysis that follows will freeze the subprogram
15817 -- being called. However, if the call is to a null procedure,
15818 -- we want to freeze it before creating the block, because the
15819 -- analysis that follows may be done with expansion disabled, in
15820 -- which case the body will not be generated, leading to spurious
15823 if Nkind
(Call
) = N_Procedure_Call_Statement
15824 and then Is_Entity_Name
(Name
(Call
))
15826 Analyze
(Name
(Call
));
15827 Freeze_Before
(N
, Entity
(Name
(Call
)));
15831 Make_Implicit_If_Statement
(N
,
15833 Then_Statements
=> New_List
(
15834 Make_Block_Statement
(Loc
,
15835 Handled_Statement_Sequence
=>
15836 Make_Handled_Sequence_Of_Statements
(Loc
,
15837 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15840 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15841 -- after analysis of the normally rewritten node, to capture all
15842 -- references to entities, which avoids issuing wrong warnings
15843 -- about unused entities.
15845 if GNATprove_Mode
then
15846 Rewrite
(N
, Make_Null_Statement
(Loc
));
15854 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15856 when Pragma_Debug_Policy
=>
15858 Check_Arg_Count
(1);
15859 Check_No_Identifiers
;
15860 Check_Arg_Is_Identifier
(Arg1
);
15862 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15863 -- rewrite it that way, and let the rest of the checking come
15864 -- from analyzing the rewritten pragma.
15868 Chars
=> Name_Check_Policy
,
15869 Pragma_Argument_Associations
=> New_List
(
15870 Make_Pragma_Argument_Association
(Loc
,
15871 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15873 Make_Pragma_Argument_Association
(Loc
,
15874 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15877 -------------------------------
15878 -- Default_Initial_Condition --
15879 -------------------------------
15881 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15883 when Pragma_Default_Initial_Condition
=> DIC
: declare
15890 Check_No_Identifiers
;
15891 Check_At_Most_N_Arguments
(2); -- Accounts for implicit type arg
15895 while Present
(Stmt
) loop
15897 -- Skip prior pragmas, but check for duplicates
15899 if Nkind
(Stmt
) = N_Pragma
then
15900 if Pragma_Name
(Stmt
) = Pname
then
15907 -- Skip internally generated code. Note that derived type
15908 -- declarations of untagged types with discriminants are
15909 -- rewritten as private type declarations.
15911 elsif not Comes_From_Source
(Stmt
)
15912 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15916 -- The associated private type [extension] has been found, stop
15919 elsif Nkind
(Stmt
) in N_Private_Extension_Declaration
15920 | N_Private_Type_Declaration
15922 Typ
:= Defining_Entity
(Stmt
);
15925 -- The pragma does not apply to a legal construct, issue an
15926 -- error and stop the analysis.
15932 Stmt
:= Prev
(Stmt
);
15935 -- The pragma does not apply to a legal construct, issue an error
15936 -- and stop the analysis.
15942 -- A pragma that applies to a Ghost entity becomes Ghost for the
15943 -- purposes of legality checks and removal of ignored Ghost code.
15945 Mark_Ghost_Pragma
(N
, Typ
);
15947 -- The pragma signals that the type defines its own DIC assertion
15950 Set_Has_Own_DIC
(Typ
);
15952 -- A type entity argument is appended to facilitate inheriting the
15953 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15954 -- though that extra argument isn't documented for the pragma.
15957 -- When the pragma has no arguments, create an argument with
15958 -- the value Empty, so the type name argument can be appended
15959 -- following it (since it's expected as the second argument).
15962 Set_Pragma_Argument_Associations
(N
, New_List
(
15963 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15964 Expression
=> Empty
)));
15968 (Pragma_Argument_Associations
(N
),
15969 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15970 Expression
=> New_Occurrence_Of
(Typ
, Sloc
(Typ
))));
15973 -- Chain the pragma on the rep item chain for further processing
15975 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15977 -- Create the declaration of the procedure which verifies the
15978 -- assertion expression of pragma DIC at runtime.
15980 Build_DIC_Procedure_Declaration
(Typ
);
15983 ----------------------------------
15984 -- Default_Scalar_Storage_Order --
15985 ----------------------------------
15987 -- pragma Default_Scalar_Storage_Order
15988 -- (High_Order_First | Low_Order_First);
15990 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15991 Default
: Character;
15995 Check_Arg_Count
(1);
15997 -- Default_Scalar_Storage_Order can appear as a configuration
15998 -- pragma, or in a declarative part of a package spec.
16000 if not Is_Configuration_Pragma
then
16001 Check_Is_In_Decl_Part_Or_Package_Spec
;
16004 Check_No_Identifiers
;
16005 Check_Arg_Is_One_Of
16006 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
16007 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16008 Default
:= Fold_Upper
(Name_Buffer
(1));
16010 if not Support_Nondefault_SSO_On_Target
16011 and then Ttypes
.Bytes_Big_Endian
/= (Default
= 'H')
16013 if Warn_On_Unrecognized_Pragma
then
16015 ("non-default Scalar_Storage_Order not supported "
16016 & "on target?g?", N
);
16018 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
16021 -- Here set the specified default
16024 Opt
.Default_SSO
:= Default
;
16028 --------------------------
16029 -- Default_Storage_Pool --
16030 --------------------------
16032 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
16034 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
16039 Check_Arg_Count
(1);
16041 -- Default_Storage_Pool can appear as a configuration pragma, or
16042 -- in a declarative part of a package spec.
16044 if not Is_Configuration_Pragma
then
16045 Check_Is_In_Decl_Part_Or_Package_Spec
;
16048 if From_Aspect_Specification
(N
) then
16050 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
16052 if not In_Open_Scopes
(E
) then
16054 ("aspect must apply to package or subprogram", N
);
16059 if Present
(Arg1
) then
16060 Pool
:= Get_Pragma_Arg
(Arg1
);
16062 -- Case of Default_Storage_Pool (null);
16064 if Nkind
(Pool
) = N_Null
then
16067 -- This is an odd case, this is not really an expression,
16068 -- so we don't have a type for it. So just set the type to
16071 Set_Etype
(Pool
, Empty
);
16073 -- Case of Default_Storage_Pool (Standard);
16075 elsif Nkind
(Pool
) = N_Identifier
16076 and then Chars
(Pool
) = Name_Standard
16080 if Entity
(Pool
) /= Standard_Standard
then
16082 ("package Standard is not directly visible", Arg1
);
16085 -- Case of Default_Storage_Pool (storage_pool_NAME);
16088 -- If it's a configuration pragma, then the only allowed
16089 -- argument is "null".
16091 if Is_Configuration_Pragma
then
16092 Error_Pragma_Arg
("NULL or Standard expected", Arg1
);
16095 -- The expected type for a non-"null" argument is
16096 -- Root_Storage_Pool'Class, and the pool must be a variable.
16098 Analyze_And_Resolve
16099 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
16101 if Is_Variable
(Pool
) then
16103 -- A pragma that applies to a Ghost entity becomes Ghost
16104 -- for the purposes of legality checks and removal of
16105 -- ignored Ghost code.
16107 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
16111 ("default storage pool must be a variable", Arg1
);
16115 -- Record the pool name (or null). Freeze.Freeze_Entity for an
16116 -- access type will use this information to set the appropriate
16117 -- attributes of the access type. If the pragma appears in a
16118 -- generic unit it is ignored, given that it may refer to a
16121 if not Inside_A_Generic
then
16122 Default_Pool
:= Pool
;
16125 end Default_Storage_Pool
;
16131 -- pragma Depends (DEPENDENCY_RELATION);
16133 -- DEPENDENCY_RELATION ::=
16135 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
16137 -- DEPENDENCY_CLAUSE ::=
16138 -- OUTPUT_LIST =>[+] INPUT_LIST
16139 -- | NULL_DEPENDENCY_CLAUSE
16141 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
16143 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
16145 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
16147 -- OUTPUT ::= NAME | FUNCTION_RESULT
16150 -- where FUNCTION_RESULT is a function Result attribute_reference
16152 -- Characteristics:
16154 -- * Analysis - The annotation undergoes initial checks to verify
16155 -- the legal placement and context. Secondary checks fully analyze
16156 -- the dependency clauses in:
16158 -- Analyze_Depends_In_Decl_Part
16160 -- * Expansion - None.
16162 -- * Template - The annotation utilizes the generic template of the
16163 -- related subprogram [body] when it is:
16165 -- aspect on subprogram declaration
16166 -- aspect on stand-alone subprogram body
16167 -- pragma on stand-alone subprogram body
16169 -- The annotation must prepare its own template when it is:
16171 -- pragma on subprogram declaration
16173 -- * Globals - Capture of global references must occur after full
16176 -- * Instance - The annotation is instantiated automatically when
16177 -- the related generic subprogram [body] is instantiated except for
16178 -- the "pragma on subprogram declaration" case. In that scenario
16179 -- the annotation must instantiate itself.
16181 when Pragma_Depends
=> Depends
: declare
16183 Spec_Id
: Entity_Id
;
16184 Subp_Decl
: Node_Id
;
16187 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16191 -- Chain the pragma on the contract for further processing by
16192 -- Analyze_Depends_In_Decl_Part.
16194 Add_Contract_Item
(N
, Spec_Id
);
16196 -- Fully analyze the pragma when it appears inside an entry
16197 -- or subprogram body because it cannot benefit from forward
16200 if Nkind
(Subp_Decl
) in N_Entry_Body
16201 | N_Subprogram_Body
16202 | N_Subprogram_Body_Stub
16204 -- The legality checks of pragmas Depends and Global are
16205 -- affected by the SPARK mode in effect and the volatility
16206 -- of the context. In addition these two pragmas are subject
16207 -- to an inherent order:
16212 -- Analyze all these pragmas in the order outlined above
16214 Analyze_If_Present
(Pragma_SPARK_Mode
);
16215 Analyze_If_Present
(Pragma_Volatile_Function
);
16216 Analyze_If_Present
(Pragma_Side_Effects
);
16217 Analyze_If_Present
(Pragma_Global
);
16218 Analyze_Depends_In_Decl_Part
(N
);
16223 ---------------------
16224 -- Detect_Blocking --
16225 ---------------------
16227 -- pragma Detect_Blocking;
16229 when Pragma_Detect_Blocking
=>
16231 Check_Arg_Count
(0);
16232 Check_Valid_Configuration_Pragma
;
16233 Detect_Blocking
:= True;
16235 ------------------------------------
16236 -- Disable_Atomic_Synchronization --
16237 ------------------------------------
16239 -- pragma Disable_Atomic_Synchronization [(Entity)];
16241 when Pragma_Disable_Atomic_Synchronization
=>
16243 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
16245 -------------------
16246 -- Discard_Names --
16247 -------------------
16249 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
16251 when Pragma_Discard_Names
=> Discard_Names
: declare
16256 Check_Ada_83_Warning
;
16258 -- Deal with configuration pragma case
16260 if Is_Configuration_Pragma
then
16261 if Arg_Count
/= 0 then
16263 ("nonzero number of arguments for configuration pragma%");
16265 Global_Discard_Names
:= True;
16269 -- Otherwise, check correct appropriate context
16272 Check_Is_In_Decl_Part_Or_Package_Spec
;
16274 if Arg_Count
= 0 then
16276 -- If there is no parameter, then from now on this pragma
16277 -- applies to any enumeration, exception or tagged type
16278 -- defined in the current declarative part, and recursively
16279 -- to any nested scope.
16281 Set_Discard_Names
(Current_Scope
);
16285 Check_Arg_Count
(1);
16286 Check_Optional_Identifier
(Arg1
, Name_On
);
16287 Check_Arg_Is_Local_Name
(Arg1
);
16289 E_Id
:= Get_Pragma_Arg
(Arg1
);
16291 if Etype
(E_Id
) = Any_Type
then
16295 E
:= Entity
(E_Id
);
16297 -- A pragma that applies to a Ghost entity becomes Ghost for
16298 -- the purposes of legality checks and removal of ignored
16301 Mark_Ghost_Pragma
(N
, E
);
16303 if (Is_First_Subtype
(E
)
16305 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
16306 or else Ekind
(E
) = E_Exception
16308 Set_Discard_Names
(E
);
16309 Record_Rep_Item
(E
, N
);
16313 ("inappropriate entity for pragma%", Arg1
);
16319 ------------------------
16320 -- Dispatching_Domain --
16321 ------------------------
16323 -- pragma Dispatching_Domain (EXPRESSION);
16325 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
16326 P
: constant Node_Id
:= Parent
(N
);
16332 Check_No_Identifiers
;
16333 Check_Arg_Count
(1);
16335 -- This pragma is born obsolete, but not the aspect
16337 if not From_Aspect_Specification
(N
) then
16339 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16342 if Nkind
(P
) = N_Task_Definition
then
16343 Arg
:= Get_Pragma_Arg
(Arg1
);
16344 Ent
:= Defining_Identifier
(Parent
(P
));
16346 -- A pragma that applies to a Ghost entity becomes Ghost for
16347 -- the purposes of legality checks and removal of ignored Ghost
16350 Mark_Ghost_Pragma
(N
, Ent
);
16352 -- The expression must be analyzed in the special manner
16353 -- described in "Handling of Default and Per-Object
16354 -- Expressions" in sem.ads.
16356 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
16358 -- Check duplicate pragma before we chain the pragma in the Rep
16359 -- Item chain of Ent.
16361 Check_Duplicate_Pragma
(Ent
);
16362 Record_Rep_Item
(Ent
, N
);
16364 -- Anything else is incorrect
16369 end Dispatching_Domain
;
16375 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
16377 when Pragma_Elaborate
=> Elaborate
: declare
16382 -- Pragma must be in context items list of a compilation unit
16384 if not Is_In_Context_Clause
then
16388 -- Must be at least one argument
16390 if Arg_Count
= 0 then
16391 Error_Pragma
("pragma% requires at least one argument");
16394 -- In Ada 83 mode, there can be no items following it in the
16395 -- context list except other pragmas and implicit with clauses
16396 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
16397 -- placement rule does not apply.
16399 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
16401 while Present
(Citem
) loop
16402 if Nkind
(Citem
) = N_Pragma
16403 or else (Nkind
(Citem
) = N_With_Clause
16404 and then Implicit_With
(Citem
))
16409 ("(Ada 83) pragma% must be at end of context clause");
16416 -- Finally, the arguments must all be units mentioned in a with
16417 -- clause in the same context clause. Note we already checked (in
16418 -- Par.Prag) that the arguments are all identifiers or selected
16422 Outer
: while Present
(Arg
) loop
16423 Citem
:= First
(List_Containing
(N
));
16424 Inner
: while Citem
/= N
loop
16425 if Nkind
(Citem
) = N_With_Clause
16426 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
16428 Set_Elaborate_Present
(Citem
, True);
16429 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
16431 -- With the pragma present, elaboration calls on
16432 -- subprograms from the named unit need no further
16433 -- checks, as long as the pragma appears in the current
16434 -- compilation unit. If the pragma appears in some unit
16435 -- in the context, there might still be a need for an
16436 -- Elaborate_All_Desirable from the current compilation
16437 -- to the named unit, so we keep the check enabled. This
16438 -- does not apply in SPARK mode, where we allow pragma
16439 -- Elaborate, but we don't trust it to be right so we
16440 -- will still insist on the Elaborate_All.
16442 if Legacy_Elaboration_Checks
16443 and then In_Extended_Main_Source_Unit
(N
)
16444 and then SPARK_Mode
/= On
16446 Set_Suppress_Elaboration_Warnings
16447 (Entity
(Name
(Citem
)));
16458 ("argument of pragma% is not withed unit", Arg
);
16465 -------------------
16466 -- Elaborate_All --
16467 -------------------
16469 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
16471 when Pragma_Elaborate_All
=> Elaborate_All
: declare
16476 Check_Ada_83_Warning
;
16478 -- Pragma must be in context items list of a compilation unit
16480 if not Is_In_Context_Clause
then
16484 -- Must be at least one argument
16486 if Arg_Count
= 0 then
16487 Error_Pragma
("pragma% requires at least one argument");
16490 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
16491 -- have to appear at the end of the context clause, but may
16492 -- appear mixed in with other items, even in Ada 83 mode.
16494 -- Final check: the arguments must all be units mentioned in
16495 -- a with clause in the same context clause. Note that we
16496 -- already checked (in Par.Prag) that all the arguments are
16497 -- either identifiers or selected components.
16500 Outr
: while Present
(Arg
) loop
16501 Citem
:= First
(List_Containing
(N
));
16502 Innr
: while Citem
/= N
loop
16503 if Nkind
(Citem
) = N_With_Clause
16504 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
16506 Set_Elaborate_All_Present
(Citem
, True);
16507 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
16509 -- Suppress warnings and elaboration checks on the named
16510 -- unit if the pragma is in the current compilation, as
16511 -- for pragma Elaborate.
16513 if Legacy_Elaboration_Checks
16514 and then In_Extended_Main_Source_Unit
(N
)
16516 Set_Suppress_Elaboration_Warnings
16517 (Entity
(Name
(Citem
)));
16528 ("argument of pragma% is not withed unit", Arg
);
16535 --------------------
16536 -- Elaborate_Body --
16537 --------------------
16539 -- pragma Elaborate_Body [( library_unit_NAME )];
16541 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
16542 Cunit_Node
: Node_Id
;
16543 Cunit_Ent
: Entity_Id
;
16546 Check_Ada_83_Warning
;
16547 Check_Valid_Library_Unit_Pragma
;
16549 -- If N was rewritten as a null statement there is nothing more
16552 if Nkind
(N
) = N_Null_Statement
then
16556 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16557 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16559 -- A pragma that applies to a Ghost entity becomes Ghost for the
16560 -- purposes of legality checks and removal of ignored Ghost code.
16562 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
16564 if Nkind
(Unit
(Cunit_Node
)) in
16565 N_Package_Body | N_Subprogram_Body
16567 Error_Pragma
("pragma% must refer to a spec, not a body");
16569 Set_Body_Required
(Cunit_Node
);
16570 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
16572 -- If we are in dynamic elaboration mode, then we suppress
16573 -- elaboration warnings for the unit, since it is definitely
16574 -- fine NOT to do dynamic checks at the first level (and such
16575 -- checks will be suppressed because no elaboration boolean
16576 -- is created for Elaborate_Body packages).
16578 -- But in the static model of elaboration, Elaborate_Body is
16579 -- definitely NOT good enough to ensure elaboration safety on
16580 -- its own, since the body may WITH other units that are not
16581 -- safe from an elaboration point of view, so a client must
16582 -- still do an Elaborate_All on such units.
16584 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16585 -- Elaborate_Body always suppressed elab warnings.
16587 if Legacy_Elaboration_Checks
16588 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
16590 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
16593 end Elaborate_Body
;
16595 ------------------------
16596 -- Elaboration_Checks --
16597 ------------------------
16599 -- pragma Elaboration_Checks (Static | Dynamic);
16601 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
16602 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
16603 -- Emit an error if the current context list already contains
16604 -- a previous Elaboration_Checks pragma. This routine raises
16605 -- Pragma_Exit if a duplicate is found.
16607 procedure Ignore_Elaboration_Checks_Pragma
;
16608 -- Warn that the effects of the pragma are ignored. This routine
16609 -- raises Pragma_Exit.
16611 -----------------------------------------------
16612 -- Check_Duplicate_Elaboration_Checks_Pragma --
16613 -----------------------------------------------
16615 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16620 while Present
(Item
) loop
16621 if Nkind
(Item
) = N_Pragma
16622 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16632 end Check_Duplicate_Elaboration_Checks_Pragma
;
16634 --------------------------------------
16635 -- Ignore_Elaboration_Checks_Pragma --
16636 --------------------------------------
16638 procedure Ignore_Elaboration_Checks_Pragma
is
16640 Error_Msg_Name_1
:= Pname
;
16641 Error_Msg_N
("??effects of pragma % are ignored", N
);
16643 ("\place pragma on initial declaration of library unit", N
);
16646 end Ignore_Elaboration_Checks_Pragma
;
16650 Context
: constant Node_Id
:= Parent
(N
);
16653 -- Start of processing for Elaboration_Checks
16657 Check_Arg_Count
(1);
16658 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16660 -- The pragma appears in a configuration file
16662 if No
(Context
) then
16663 Check_Valid_Configuration_Pragma
;
16664 Check_Duplicate_Elaboration_Checks_Pragma
;
16666 -- The pragma acts as a configuration pragma in a compilation unit
16668 -- pragma Elaboration_Checks (...);
16669 -- package Pack is ...;
16671 elsif Nkind
(Context
) = N_Compilation_Unit
16672 and then List_Containing
(N
) = Context_Items
(Context
)
16674 Check_Valid_Configuration_Pragma
;
16675 Check_Duplicate_Elaboration_Checks_Pragma
;
16677 Unt
:= Unit
(Context
);
16679 -- The pragma must appear on the initial declaration of a unit.
16680 -- If this is not the case, warn that the effects of the pragma
16683 if Nkind
(Unt
) = N_Package_Body
then
16684 Ignore_Elaboration_Checks_Pragma
;
16686 -- Check the Acts_As_Spec flag of the compilation units itself
16687 -- to determine whether the subprogram body completes since it
16688 -- has not been analyzed yet. This is safe because compilation
16689 -- units are not overloadable.
16691 elsif Nkind
(Unt
) = N_Subprogram_Body
16692 and then not Acts_As_Spec
(Context
)
16694 Ignore_Elaboration_Checks_Pragma
;
16696 elsif Nkind
(Unt
) = N_Subunit
then
16697 Ignore_Elaboration_Checks_Pragma
;
16700 -- Otherwise the pragma does not appear at the configuration level
16707 -- At this point the pragma is not a duplicate, and appears in the
16708 -- proper context. Set the elaboration model in effect.
16710 Dynamic_Elaboration_Checks
:=
16711 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16712 end Elaboration_Checks
;
16718 -- pragma Eliminate (
16719 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16720 -- [Entity =>] IDENTIFIER |
16721 -- SELECTED_COMPONENT |
16723 -- [, Source_Location => SOURCE_TRACE]);
16725 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16726 -- SOURCE_TRACE ::= STRING_LITERAL
16728 when Pragma_Eliminate
=> Eliminate
: declare
16729 Args
: Args_List
(1 .. 5);
16730 Names
: constant Name_List
(1 .. 5) := (
16733 Name_Parameter_Types
,
16735 Name_Source_Location
);
16737 -- Note : Parameter_Types and Result_Type are leftovers from
16738 -- prior implementations of the pragma. They are not generated
16739 -- by the gnatelim tool, and play no role in selecting which
16740 -- of a set of overloaded names is chosen for elimination.
16742 Unit_Name
: Node_Id
renames Args
(1);
16743 Entity
: Node_Id
renames Args
(2);
16744 Parameter_Types
: Node_Id
renames Args
(3);
16745 Result_Type
: Node_Id
renames Args
(4);
16746 Source_Location
: Node_Id
renames Args
(5);
16750 Check_Valid_Configuration_Pragma
;
16751 Gather_Associations
(Names
, Args
);
16753 if No
(Unit_Name
) then
16754 Error_Pragma
("missing Unit_Name argument for pragma%");
16758 and then (Present
(Parameter_Types
)
16760 Present
(Result_Type
)
16762 Present
(Source_Location
))
16764 Error_Pragma
("missing Entity argument for pragma%");
16767 if (Present
(Parameter_Types
)
16769 Present
(Result_Type
))
16771 Present
(Source_Location
)
16774 ("parameter profile and source location cannot be used "
16775 & "together in pragma%");
16778 Process_Eliminate_Pragma
16787 -----------------------------------
16788 -- Enable_Atomic_Synchronization --
16789 -----------------------------------
16791 -- pragma Enable_Atomic_Synchronization [(Entity)];
16793 when Pragma_Enable_Atomic_Synchronization
=>
16795 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16797 -----------------------
16798 -- Exceptional_Cases --
16799 -----------------------
16801 -- pragma Exceptional_Cases ( EXCEPTIONAL_CONTRACT_LIST );
16803 -- EXCEPTIONAL_CONTRACT_LIST ::=
16804 -- ( EXCEPTIONAL_CONTRACT {, EXCEPTIONAL_CONTRACT })
16806 -- EXCEPTIONAL_CONTRACT ::=
16807 -- EXCEPTION_CHOICE {'|' EXCEPTION_CHOICE} => CONSEQUENCE
16811 -- CONSEQUENCE ::= boolean_EXPRESSION
16813 -- Characteristics:
16815 -- * Analysis - The annotation undergoes initial checks to verify
16816 -- the legal placement and context. Secondary checks preanalyze the
16819 -- Analyze_Exceptional_Cases_In_Decl_Part
16821 -- * Expansion - The annotation is expanded during the expansion of
16822 -- the related subprogram [body] contract as performed in:
16824 -- Expand_Subprogram_Contract
16826 -- * Template - The annotation utilizes the generic template of the
16827 -- related subprogram [body] when it is:
16829 -- aspect on subprogram declaration
16830 -- aspect on stand-alone subprogram body
16831 -- pragma on stand-alone subprogram body
16833 -- The annotation must prepare its own template when it is:
16835 -- pragma on subprogram declaration
16837 -- * Globals - Capture of global references must occur after full
16840 -- * Instance - The annotation is instantiated automatically when
16841 -- the related generic subprogram [body] is instantiated except for
16842 -- the "pragma on subprogram declaration" case. In that scenario
16843 -- the annotation must instantiate itself.
16845 when Pragma_Exceptional_Cases
=> Exceptional_Cases
: declare
16846 Spec_Id
: Entity_Id
;
16847 Subp_Decl
: Node_Id
;
16848 Subp_Spec
: Node_Id
;
16852 Check_No_Identifiers
;
16853 Check_Arg_Count
(1);
16855 -- Ensure the proper placement of the pragma. Exceptional_Cases
16856 -- must be associated with a subprogram declaration or a body that
16860 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16862 -- Generic subprogram
16864 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16867 -- Body acts as spec
16869 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16870 and then No
(Corresponding_Spec
(Subp_Decl
))
16874 -- Body stub acts as spec
16876 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16877 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16883 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16884 Subp_Spec
:= Specification
(Subp_Decl
);
16886 -- Pragma Exceptional_Cases is forbidden on null procedures,
16887 -- as this may lead to potential ambiguities in behavior when
16888 -- interface null procedures are involved. Also, it just
16889 -- wouldn't make sense, because null procedures do not raise
16892 if Nkind
(Subp_Spec
) = N_Procedure_Specification
16893 and then Null_Present
(Subp_Spec
)
16895 Error_Msg_N
(Fix_Error
16896 ("pragma % cannot apply to null procedure"), N
);
16904 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16906 -- In order to call Is_Function_With_Side_Effects, analyze pragma
16907 -- Side_Effects if present.
16909 Analyze_If_Present
(Pragma_Side_Effects
);
16911 -- Pragma Exceptional_Cases is not allowed on functions without
16914 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
16915 and then not Is_Function_With_Side_Effects
(Spec_Id
)
16917 Error_Msg_Sloc
:= GEC_Exceptional_Cases_On_Function
;
16919 if Ekind
(Spec_Id
) = E_Function
then
16920 Error_Msg_N
(Fix_Error
16921 ("pragma % cannot apply to function '[[]']"), N
);
16924 elsif Ekind
(Spec_Id
) = E_Generic_Function
then
16925 Error_Msg_N
(Fix_Error
16926 ("pragma % cannot apply to generic function '[[]']"), N
);
16931 -- A pragma that applies to a Ghost entity becomes Ghost for the
16932 -- purposes of legality checks and removal of ignored Ghost code.
16934 Mark_Ghost_Pragma
(N
, Spec_Id
);
16935 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
16937 -- Chain the pragma on the contract for further processing by
16938 -- Analyze_Exceptional_Cases_In_Decl_Part.
16940 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16942 -- Fully analyze the pragma when it appears inside a subprogram
16943 -- body because it cannot benefit from forward references.
16945 if Nkind
(Subp_Decl
) in N_Subprogram_Body
16946 | N_Subprogram_Body_Stub
16948 -- The legality checks of pragma Exceptional_Cases are
16949 -- affected by the SPARK mode in effect and the volatility
16950 -- of the context. Analyze all pragmas in a specific order.
16952 Analyze_If_Present
(Pragma_SPARK_Mode
);
16953 Analyze_If_Present
(Pragma_Volatile_Function
);
16954 Analyze_Exceptional_Cases_In_Decl_Part
(N
);
16956 end Exceptional_Cases
;
16963 -- [ Convention =>] convention_IDENTIFIER,
16964 -- [ Entity =>] LOCAL_NAME
16965 -- [, [External_Name =>] static_string_EXPRESSION ]
16966 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16968 when Pragma_Export
=> Export
: declare
16970 Def_Id
: Entity_Id
;
16972 pragma Warnings
(Off
, C
);
16975 Check_Ada_83_Warning
;
16979 Name_External_Name
,
16982 Check_At_Least_N_Arguments
(2);
16983 Check_At_Most_N_Arguments
(4);
16985 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16986 -- pragma Export (Entity, "external name");
16988 if Relaxed_RM_Semantics
16989 and then Arg_Count
= 2
16990 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16993 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16996 if not Is_Entity_Name
(Def_Id
) then
16997 Error_Pragma_Arg
("entity name required", Arg1
);
17000 Def_Id
:= Entity
(Def_Id
);
17001 Set_Exported
(Def_Id
, Arg1
);
17004 Process_Convention
(C
, Def_Id
);
17006 -- A pragma that applies to a Ghost entity becomes Ghost for
17007 -- the purposes of legality checks and removal of ignored Ghost
17010 Mark_Ghost_Pragma
(N
, Def_Id
);
17012 if Ekind
(Def_Id
) /= E_Constant
then
17013 Note_Possible_Modification
17014 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
17017 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
17018 Set_Exported
(Def_Id
, Arg2
);
17021 -- If the entity is a deferred constant, propagate the information
17022 -- to the full view, because gigi elaborates the full view only.
17024 if Ekind
(Def_Id
) = E_Constant
17025 and then Present
(Full_View
(Def_Id
))
17028 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
17030 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
17031 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
17033 (Id2
, Einfo
.Entities
.Interface_Name
(Def_Id
));
17038 ---------------------
17039 -- Export_Function --
17040 ---------------------
17042 -- pragma Export_Function (
17043 -- [Internal =>] LOCAL_NAME
17044 -- [, [External =>] EXTERNAL_SYMBOL]
17045 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17046 -- [, [Result_Type =>] TYPE_DESIGNATOR]
17047 -- [, [Mechanism =>] MECHANISM]
17048 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17050 -- EXTERNAL_SYMBOL ::=
17052 -- | static_string_EXPRESSION
17054 -- PARAMETER_TYPES ::=
17056 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17058 -- TYPE_DESIGNATOR ::=
17060 -- | subtype_Name ' Access
17064 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17066 -- MECHANISM_ASSOCIATION ::=
17067 -- [formal_parameter_NAME =>] MECHANISM_NAME
17069 -- MECHANISM_NAME ::=
17073 when Pragma_Export_Function
=> Export_Function
: declare
17074 Args
: Args_List
(1 .. 6);
17075 Names
: constant Name_List
(1 .. 6) := (
17078 Name_Parameter_Types
,
17081 Name_Result_Mechanism
);
17083 Internal
: Node_Id
renames Args
(1);
17084 External
: Node_Id
renames Args
(2);
17085 Parameter_Types
: Node_Id
renames Args
(3);
17086 Result_Type
: Node_Id
renames Args
(4);
17087 Mechanism
: Node_Id
renames Args
(5);
17088 Result_Mechanism
: Node_Id
renames Args
(6);
17092 Gather_Associations
(Names
, Args
);
17093 Process_Extended_Import_Export_Subprogram_Pragma
(
17094 Arg_Internal
=> Internal
,
17095 Arg_External
=> External
,
17096 Arg_Parameter_Types
=> Parameter_Types
,
17097 Arg_Result_Type
=> Result_Type
,
17098 Arg_Mechanism
=> Mechanism
,
17099 Arg_Result_Mechanism
=> Result_Mechanism
);
17100 end Export_Function
;
17102 -------------------
17103 -- Export_Object --
17104 -------------------
17106 -- pragma Export_Object (
17107 -- [Internal =>] LOCAL_NAME
17108 -- [, [External =>] EXTERNAL_SYMBOL]
17109 -- [, [Size =>] EXTERNAL_SYMBOL]);
17111 -- EXTERNAL_SYMBOL ::=
17113 -- | static_string_EXPRESSION
17115 -- PARAMETER_TYPES ::=
17117 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17119 -- TYPE_DESIGNATOR ::=
17121 -- | subtype_Name ' Access
17125 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17127 -- MECHANISM_ASSOCIATION ::=
17128 -- [formal_parameter_NAME =>] MECHANISM_NAME
17130 -- MECHANISM_NAME ::=
17134 when Pragma_Export_Object
=> Export_Object
: declare
17135 Args
: Args_List
(1 .. 3);
17136 Names
: constant Name_List
(1 .. 3) := (
17141 Internal
: Node_Id
renames Args
(1);
17142 External
: Node_Id
renames Args
(2);
17143 Size
: Node_Id
renames Args
(3);
17147 Gather_Associations
(Names
, Args
);
17148 Process_Extended_Import_Export_Object_Pragma
(
17149 Arg_Internal
=> Internal
,
17150 Arg_External
=> External
,
17154 ----------------------
17155 -- Export_Procedure --
17156 ----------------------
17158 -- pragma Export_Procedure (
17159 -- [Internal =>] LOCAL_NAME
17160 -- [, [External =>] EXTERNAL_SYMBOL]
17161 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17162 -- [, [Mechanism =>] MECHANISM]);
17164 -- EXTERNAL_SYMBOL ::=
17166 -- | static_string_EXPRESSION
17168 -- PARAMETER_TYPES ::=
17170 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17172 -- TYPE_DESIGNATOR ::=
17174 -- | subtype_Name ' Access
17178 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17180 -- MECHANISM_ASSOCIATION ::=
17181 -- [formal_parameter_NAME =>] MECHANISM_NAME
17183 -- MECHANISM_NAME ::=
17187 when Pragma_Export_Procedure
=> Export_Procedure
: declare
17188 Args
: Args_List
(1 .. 4);
17189 Names
: constant Name_List
(1 .. 4) := (
17192 Name_Parameter_Types
,
17195 Internal
: Node_Id
renames Args
(1);
17196 External
: Node_Id
renames Args
(2);
17197 Parameter_Types
: Node_Id
renames Args
(3);
17198 Mechanism
: Node_Id
renames Args
(4);
17202 Gather_Associations
(Names
, Args
);
17203 Process_Extended_Import_Export_Subprogram_Pragma
(
17204 Arg_Internal
=> Internal
,
17205 Arg_External
=> External
,
17206 Arg_Parameter_Types
=> Parameter_Types
,
17207 Arg_Mechanism
=> Mechanism
);
17208 end Export_Procedure
;
17210 -----------------------------
17211 -- Export_Valued_Procedure --
17212 -----------------------------
17214 -- pragma Export_Valued_Procedure (
17215 -- [Internal =>] LOCAL_NAME
17216 -- [, [External =>] EXTERNAL_SYMBOL,]
17217 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17218 -- [, [Mechanism =>] MECHANISM]);
17220 -- EXTERNAL_SYMBOL ::=
17222 -- | static_string_EXPRESSION
17224 -- PARAMETER_TYPES ::=
17226 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17228 -- TYPE_DESIGNATOR ::=
17230 -- | subtype_Name ' Access
17234 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17236 -- MECHANISM_ASSOCIATION ::=
17237 -- [formal_parameter_NAME =>] MECHANISM_NAME
17239 -- MECHANISM_NAME ::=
17243 when Pragma_Export_Valued_Procedure
=>
17244 Export_Valued_Procedure
: declare
17245 Args
: Args_List
(1 .. 4);
17246 Names
: constant Name_List
(1 .. 4) := (
17249 Name_Parameter_Types
,
17252 Internal
: Node_Id
renames Args
(1);
17253 External
: Node_Id
renames Args
(2);
17254 Parameter_Types
: Node_Id
renames Args
(3);
17255 Mechanism
: Node_Id
renames Args
(4);
17259 Gather_Associations
(Names
, Args
);
17260 Process_Extended_Import_Export_Subprogram_Pragma
(
17261 Arg_Internal
=> Internal
,
17262 Arg_External
=> External
,
17263 Arg_Parameter_Types
=> Parameter_Types
,
17264 Arg_Mechanism
=> Mechanism
);
17265 end Export_Valued_Procedure
;
17267 -------------------
17268 -- Extend_System --
17269 -------------------
17271 -- pragma Extend_System ([Name =>] Identifier);
17273 when Pragma_Extend_System
=>
17275 Check_Valid_Configuration_Pragma
;
17276 Check_Arg_Count
(1);
17277 Check_Optional_Identifier
(Arg1
, Name_Name
);
17278 Check_Arg_Is_Identifier
(Arg1
);
17280 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
17283 and then Name_Buffer
(1 .. 4) = "aux_"
17285 if Present
(System_Extend_Pragma_Arg
) then
17286 if Chars
(Get_Pragma_Arg
(Arg1
)) =
17287 Chars
(Expression
(System_Extend_Pragma_Arg
))
17291 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
17292 Error_Pragma
("pragma% conflicts with that #");
17296 System_Extend_Pragma_Arg
:= Arg1
;
17298 if not GNAT_Mode
then
17299 System_Extend_Unit
:= Arg1
;
17303 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
17306 ------------------------
17307 -- Extensions_Allowed --
17308 ------------------------
17310 -- pragma Extensions_Allowed (ON | OFF | ALL);
17312 when Pragma_Extensions_Allowed
=>
17314 Check_Arg_Count
(1);
17315 Check_No_Identifiers
;
17316 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
, Name_All
);
17318 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
17319 Ada_Version
:= Ada_With_Core_Extensions
;
17320 elsif Chars
(Get_Pragma_Arg
(Arg1
)) = Name_All
then
17321 Ada_Version
:= Ada_With_All_Extensions
;
17323 Ada_Version
:= Ada_Version_Explicit
;
17324 Ada_Version_Pragma
:= Empty
;
17327 ------------------------
17328 -- Extensions_Visible --
17329 ------------------------
17331 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
17333 -- Characteristics:
17335 -- * Analysis - The annotation is fully analyzed immediately upon
17336 -- elaboration as its expression must be static.
17338 -- * Expansion - None.
17340 -- * Template - The annotation utilizes the generic template of the
17341 -- related subprogram [body] when it is:
17343 -- aspect on subprogram declaration
17344 -- aspect on stand-alone subprogram body
17345 -- pragma on stand-alone subprogram body
17347 -- The annotation must prepare its own template when it is:
17349 -- pragma on subprogram declaration
17351 -- * Globals - Capture of global references must occur after full
17354 -- * Instance - The annotation is instantiated automatically when
17355 -- the related generic subprogram [body] is instantiated except for
17356 -- the "pragma on subprogram declaration" case. In that scenario
17357 -- the annotation must instantiate itself.
17359 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
17360 Formal
: Entity_Id
;
17361 Has_OK_Formal
: Boolean := False;
17362 Spec_Id
: Entity_Id
;
17363 Subp_Decl
: Node_Id
;
17367 Check_No_Identifiers
;
17368 Check_At_Most_N_Arguments
(1);
17371 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
17373 -- Abstract subprogram declaration
17375 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
17378 -- Generic subprogram declaration
17380 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
17383 -- Body acts as spec
17385 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
17386 and then No
(Corresponding_Spec
(Subp_Decl
))
17390 -- Body stub acts as spec
17392 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
17393 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
17397 -- Subprogram declaration
17399 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
17402 -- Otherwise the pragma is associated with an illegal construct
17405 Error_Pragma
("pragma % must apply to a subprogram");
17408 -- Mark the pragma as Ghost if the related subprogram is also
17409 -- Ghost. This also ensures that any expansion performed further
17410 -- below will produce Ghost nodes.
17412 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
17413 Mark_Ghost_Pragma
(N
, Spec_Id
);
17415 -- Chain the pragma on the contract for completeness
17417 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
17419 -- The legality checks of pragma Extension_Visible are affected
17420 -- by the SPARK mode in effect. Analyze all pragmas in specific
17423 Analyze_If_Present
(Pragma_SPARK_Mode
);
17425 -- Examine the formals of the related subprogram
17427 Formal
:= First_Formal
(Spec_Id
);
17428 while Present
(Formal
) loop
17430 -- At least one of the formals is of a specific tagged type,
17431 -- the pragma is legal.
17433 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
17434 Has_OK_Formal
:= True;
17437 -- A generic subprogram with at least one formal of a private
17438 -- type ensures the legality of the pragma because the actual
17439 -- may be specifically tagged. Note that this is verified by
17440 -- the check above at instantiation time.
17442 elsif Is_Private_Type
(Etype
(Formal
))
17443 and then Is_Generic_Type
(Etype
(Formal
))
17445 Has_OK_Formal
:= True;
17449 Next_Formal
(Formal
);
17452 if not Has_OK_Formal
then
17453 Error_Msg_Name_1
:= Pname
;
17454 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
17456 ("\subprogram & lacks parameter of specific tagged or "
17457 & "generic private type", N
, Spec_Id
);
17462 -- Analyze the Boolean expression (if any)
17464 if Present
(Arg1
) then
17465 Check_Static_Boolean_Expression
17466 (Expression
(Get_Argument
(N
, Spec_Id
)));
17468 end Extensions_Visible
;
17474 -- pragma External (
17475 -- [ Convention =>] convention_IDENTIFIER,
17476 -- [ Entity =>] LOCAL_NAME
17477 -- [, [External_Name =>] static_string_EXPRESSION ]
17478 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17480 when Pragma_External
=> External
: declare
17483 pragma Warnings
(Off
, C
);
17490 Name_External_Name
,
17492 Check_At_Least_N_Arguments
(2);
17493 Check_At_Most_N_Arguments
(4);
17494 Process_Convention
(C
, E
);
17496 -- A pragma that applies to a Ghost entity becomes Ghost for the
17497 -- purposes of legality checks and removal of ignored Ghost code.
17499 Mark_Ghost_Pragma
(N
, E
);
17501 Note_Possible_Modification
17502 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
17503 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
17504 Set_Exported
(E
, Arg2
);
17507 --------------------------
17508 -- External_Name_Casing --
17509 --------------------------
17511 -- pragma External_Name_Casing (
17512 -- UPPERCASE | LOWERCASE
17513 -- [, AS_IS | UPPERCASE | LOWERCASE]);
17515 when Pragma_External_Name_Casing
=>
17517 Check_No_Identifiers
;
17519 if Arg_Count
= 2 then
17520 Check_Arg_Is_One_Of
17521 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
17523 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17525 Opt
.External_Name_Exp_Casing
:= As_Is
;
17527 when Name_Uppercase
=>
17528 Opt
.External_Name_Exp_Casing
:= Uppercase
;
17530 when Name_Lowercase
=>
17531 Opt
.External_Name_Exp_Casing
:= Lowercase
;
17538 Check_Arg_Count
(1);
17541 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
17543 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17544 when Name_Uppercase
=>
17545 Opt
.External_Name_Imp_Casing
:= Uppercase
;
17547 when Name_Lowercase
=>
17548 Opt
.External_Name_Imp_Casing
:= Lowercase
;
17558 -- pragma Fast_Math;
17560 when Pragma_Fast_Math
=>
17562 Check_No_Identifiers
;
17563 Check_Valid_Configuration_Pragma
;
17566 --------------------------
17567 -- Favor_Top_Level --
17568 --------------------------
17570 -- pragma Favor_Top_Level (type_NAME);
17572 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
17577 Check_No_Identifiers
;
17578 Check_Arg_Count
(1);
17579 Check_Arg_Is_Local_Name
(Arg1
);
17580 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
17582 -- A pragma that applies to a Ghost entity becomes Ghost for the
17583 -- purposes of legality checks and removal of ignored Ghost code.
17585 Mark_Ghost_Pragma
(N
, Typ
);
17587 -- If it's an access-to-subprogram type (in particular, not a
17588 -- subtype), set the flag on that type.
17590 if Is_Access_Subprogram_Type
(Typ
) then
17591 Set_Can_Use_Internal_Rep
(Typ
, False);
17593 -- Otherwise it's an error (name denotes the wrong sort of entity)
17597 ("access-to-subprogram type expected",
17598 Get_Pragma_Arg
(Arg1
));
17600 end Favor_Top_Level
;
17602 ---------------------------
17603 -- Finalize_Storage_Only --
17604 ---------------------------
17606 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
17608 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
17609 Assoc
: constant Node_Id
:= Arg1
;
17610 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
17615 Check_No_Identifiers
;
17616 Check_Arg_Count
(1);
17617 Check_Arg_Is_Local_Name
(Arg1
);
17619 Find_Type
(Type_Id
);
17620 Typ
:= Entity
(Type_Id
);
17623 or else Rep_Item_Too_Early
(Typ
, N
)
17627 Typ
:= Underlying_Type
(Typ
);
17630 if not Is_Controlled
(Typ
) then
17631 Error_Pragma
("pragma% must specify controlled type");
17634 Check_First_Subtype
(Arg1
);
17636 if Finalize_Storage_Only
(Typ
) then
17637 Error_Pragma
("duplicate pragma%, only one allowed");
17639 elsif not Rep_Item_Too_Late
(Typ
, N
) then
17640 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
17642 end Finalize_Storage
;
17648 -- pragma Ghost [ (boolean_EXPRESSION) ];
17650 when Pragma_Ghost
=> Ghost
: declare
17654 Orig_Stmt
: Node_Id
;
17655 Prev_Id
: Entity_Id
;
17660 Check_No_Identifiers
;
17661 Check_At_Most_N_Arguments
(1);
17665 while Present
(Stmt
) loop
17667 -- Skip prior pragmas, but check for duplicates
17669 if Nkind
(Stmt
) = N_Pragma
then
17670 if Pragma_Name
(Stmt
) = Pname
then
17677 -- Task unit declared without a definition cannot be subject to
17678 -- pragma Ghost (SPARK RM 6.9(19)).
17680 elsif Nkind
(Stmt
) in
17681 N_Single_Task_Declaration | N_Task_Type_Declaration
17683 Error_Pragma
("pragma % cannot apply to a task type");
17685 -- Skip internally generated code
17687 elsif not Comes_From_Source
(Stmt
) then
17688 Orig_Stmt
:= Original_Node
(Stmt
);
17690 -- When pragma Ghost applies to an untagged derivation, the
17691 -- derivation is transformed into a [sub]type declaration.
17694 N_Full_Type_Declaration | N_Subtype_Declaration
17695 and then Comes_From_Source
(Orig_Stmt
)
17696 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
17697 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
17698 N_Derived_Type_Definition
17700 Id
:= Defining_Entity
(Stmt
);
17703 -- When pragma Ghost applies to an object declaration which
17704 -- is initialized by means of a function call that returns
17705 -- on the secondary stack, the object declaration becomes a
17708 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
17709 and then Comes_From_Source
(Orig_Stmt
)
17710 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
17712 Id
:= Defining_Entity
(Stmt
);
17715 -- When pragma Ghost applies to an expression function, the
17716 -- expression function is transformed into a subprogram.
17718 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
17719 and then Comes_From_Source
(Orig_Stmt
)
17720 and then Nkind
(Orig_Stmt
) = N_Expression_Function
17722 Id
:= Defining_Entity
(Stmt
);
17725 -- When pragma Ghost applies to a generic formal type, the
17726 -- type declaration in the instantiation is a generated
17727 -- subtype declaration.
17729 elsif Nkind
(Stmt
) = N_Subtype_Declaration
17730 and then Present
(Generic_Parent_Type
(Stmt
))
17732 Id
:= Defining_Entity
(Stmt
);
17736 -- The pragma applies to a legal construct, stop the traversal
17738 elsif Nkind
(Stmt
) in N_Abstract_Subprogram_Declaration
17739 | N_Formal_Object_Declaration
17740 | N_Formal_Subprogram_Declaration
17741 | N_Formal_Type_Declaration
17742 | N_Full_Type_Declaration
17743 | N_Generic_Subprogram_Declaration
17744 | N_Object_Declaration
17745 | N_Private_Extension_Declaration
17746 | N_Private_Type_Declaration
17747 | N_Subprogram_Declaration
17748 | N_Subtype_Declaration
17750 Id
:= Defining_Entity
(Stmt
);
17753 -- The pragma does not apply to a legal construct, issue an
17754 -- error and stop the analysis.
17758 ("pragma % must apply to an object, package, subprogram "
17762 Stmt
:= Prev
(Stmt
);
17765 Context
:= Parent
(N
);
17767 -- Handle compilation units
17769 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17770 Context
:= Unit
(Parent
(Context
));
17773 -- Protected and task types cannot be subject to pragma Ghost
17774 -- (SPARK RM 6.9(19)).
17776 if Nkind
(Context
) in N_Protected_Body | N_Protected_Definition
17778 Error_Pragma
("pragma % cannot apply to a protected type");
17780 elsif Nkind
(Context
) in N_Task_Body | N_Task_Definition
then
17781 Error_Pragma
("pragma % cannot apply to a task type");
17786 -- When pragma Ghost is associated with a [generic] package, it
17787 -- appears in the visible declarations.
17789 if Nkind
(Context
) = N_Package_Specification
17790 and then Present
(Visible_Declarations
(Context
))
17791 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17793 Id
:= Defining_Entity
(Context
);
17795 -- Pragma Ghost applies to a stand-alone subprogram body
17797 elsif Nkind
(Context
) = N_Subprogram_Body
17798 and then No
(Corresponding_Spec
(Context
))
17800 Id
:= Defining_Entity
(Context
);
17802 -- Pragma Ghost applies to a subprogram declaration that acts
17803 -- as a compilation unit.
17805 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17806 Id
:= Defining_Entity
(Context
);
17808 -- Pragma Ghost applies to a generic subprogram
17810 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17811 Id
:= Defining_Entity
(Specification
(Context
));
17817 ("pragma % must apply to an object, package, subprogram or "
17821 -- Handle completions of types and constants that are subject to
17824 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17825 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17827 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17828 Error_Msg_Name_1
:= Pname
;
17830 -- The full declaration of a deferred constant cannot be
17831 -- subject to pragma Ghost unless the deferred declaration
17832 -- is also Ghost (SPARK RM 6.9(9)).
17834 if Ekind
(Prev_Id
) = E_Constant
then
17835 Error_Msg_Name_1
:= Pname
;
17836 Error_Msg_NE
(Fix_Error
17837 ("pragma % must apply to declaration of deferred "
17838 & "constant &"), N
, Id
);
17841 -- Pragma Ghost may appear on the full view of an incomplete
17842 -- type because the incomplete declaration lacks aspects and
17843 -- cannot be subject to pragma Ghost.
17845 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17848 -- The full declaration of a type cannot be subject to
17849 -- pragma Ghost unless the partial view is also Ghost
17850 -- (SPARK RM 6.9(9)).
17853 Error_Msg_NE
(Fix_Error
17854 ("pragma % must apply to partial view of type &"),
17860 -- A synchronized object cannot be subject to pragma Ghost
17861 -- (SPARK RM 6.9(19)).
17863 elsif Ekind
(Id
) = E_Variable
then
17864 if Is_Protected_Type
(Etype
(Id
)) then
17865 Error_Pragma
("pragma % cannot apply to a protected object");
17867 elsif Is_Task_Type
(Etype
(Id
)) then
17868 Error_Pragma
("pragma % cannot apply to a task object");
17872 -- Analyze the Boolean expression (if any)
17874 if Present
(Arg1
) then
17875 Expr
:= Get_Pragma_Arg
(Arg1
);
17877 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17879 if Is_OK_Static_Expression
(Expr
) then
17881 -- "Ghostness" cannot be turned off once enabled within a
17882 -- region (SPARK RM 6.9(6)).
17884 if Is_False
(Expr_Value
(Expr
))
17885 and then Ghost_Mode
> None
17888 ("pragma % with value False cannot appear in enabled "
17892 -- Otherwise the expression is not static
17896 ("expression of pragma % must be static", Expr
);
17900 Set_Is_Ghost_Entity
(Id
);
17907 -- pragma Global (GLOBAL_SPECIFICATION);
17909 -- GLOBAL_SPECIFICATION ::=
17912 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17914 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17916 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17917 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17918 -- GLOBAL_ITEM ::= NAME
17920 -- Characteristics:
17922 -- * Analysis - The annotation undergoes initial checks to verify
17923 -- the legal placement and context. Secondary checks fully analyze
17924 -- the dependency clauses in:
17926 -- Analyze_Global_In_Decl_Part
17928 -- * Expansion - None.
17930 -- * Template - The annotation utilizes the generic template of the
17931 -- related subprogram [body] when it is:
17933 -- aspect on subprogram declaration
17934 -- aspect on stand-alone subprogram body
17935 -- pragma on stand-alone subprogram body
17937 -- The annotation must prepare its own template when it is:
17939 -- pragma on subprogram declaration
17941 -- * Globals - Capture of global references must occur after full
17944 -- * Instance - The annotation is instantiated automatically when
17945 -- the related generic subprogram [body] is instantiated except for
17946 -- the "pragma on subprogram declaration" case. In that scenario
17947 -- the annotation must instantiate itself.
17949 when Pragma_Global
=> Global
: declare
17951 Spec_Id
: Entity_Id
;
17952 Subp_Decl
: Node_Id
;
17955 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17959 -- Chain the pragma on the contract for further processing by
17960 -- Analyze_Global_In_Decl_Part.
17962 Add_Contract_Item
(N
, Spec_Id
);
17964 -- Fully analyze the pragma when it appears inside an entry
17965 -- or subprogram body because it cannot benefit from forward
17968 if Nkind
(Subp_Decl
) in N_Entry_Body
17969 | N_Subprogram_Body
17970 | N_Subprogram_Body_Stub
17972 -- The legality checks of pragmas Depends and Global are
17973 -- affected by the SPARK mode in effect and the volatility
17974 -- of the context. In addition these two pragmas are subject
17975 -- to an inherent order:
17980 -- Analyze all these pragmas in the order outlined above
17982 Analyze_If_Present
(Pragma_SPARK_Mode
);
17983 Analyze_If_Present
(Pragma_Volatile_Function
);
17984 Analyze_If_Present
(Pragma_Side_Effects
);
17985 Analyze_Global_In_Decl_Part
(N
);
17986 Analyze_If_Present
(Pragma_Depends
);
17995 -- pragma Ident (static_string_EXPRESSION)
17997 -- Note: pragma Comment shares this processing. Pragma Ident is
17998 -- identical in effect to pragma Commment.
18000 when Pragma_Comment
18008 Check_Arg_Count
(1);
18009 Check_No_Identifiers
;
18010 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18013 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
18020 GP
:= Parent
(Parent
(N
));
18023 N_Package_Declaration | N_Generic_Package_Declaration
18028 -- If we have a compilation unit, then record the ident value,
18029 -- checking for improper duplication.
18031 if Nkind
(GP
) = N_Compilation_Unit
then
18032 CS
:= Ident_String
(Current_Sem_Unit
);
18034 if Present
(CS
) then
18036 -- If we have multiple instances, concatenate them.
18038 Start_String
(Strval
(CS
));
18039 Store_String_Char
(' ');
18040 Store_String_Chars
(Strval
(Str
));
18041 Set_Strval
(CS
, End_String
);
18044 Set_Ident_String
(Current_Sem_Unit
, Str
);
18047 -- For subunits, we just ignore the Ident, since in GNAT these
18048 -- are not separate object files, and hence not separate units
18049 -- in the unit table.
18051 elsif Nkind
(GP
) = N_Subunit
then
18057 -------------------
18058 -- Ignore_Pragma --
18059 -------------------
18061 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
18063 -- Entirely handled in the parser, nothing to do here
18065 when Pragma_Ignore_Pragma
=>
18068 ----------------------------
18069 -- Implementation_Defined --
18070 ----------------------------
18072 -- pragma Implementation_Defined (LOCAL_NAME);
18074 -- Marks previously declared entity as implementation defined. For
18075 -- an overloaded entity, applies to the most recent homonym.
18077 -- pragma Implementation_Defined;
18079 -- The form with no arguments appears anywhere within a scope, most
18080 -- typically a package spec, and indicates that all entities that are
18081 -- defined within the package spec are Implementation_Defined.
18083 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
18088 Check_No_Identifiers
;
18090 -- Form with no arguments
18092 if Arg_Count
= 0 then
18093 Set_Is_Implementation_Defined
(Current_Scope
);
18095 -- Form with one argument
18098 Check_Arg_Count
(1);
18099 Check_Arg_Is_Local_Name
(Arg1
);
18100 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18101 Set_Is_Implementation_Defined
(Ent
);
18103 end Implementation_Defined
;
18109 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
18111 -- IMPLEMENTATION_KIND ::=
18112 -- By_Entry | By_Protected_Procedure | By_Any | Optional
18114 -- "By_Any" and "Optional" are treated as synonyms in order to
18115 -- support Ada 2012 aspect Synchronization.
18117 when Pragma_Implemented
=> Implemented
: declare
18118 Proc_Id
: Entity_Id
;
18123 Check_Arg_Count
(2);
18124 Check_No_Identifiers
;
18125 Check_Arg_Is_Identifier
(Arg1
);
18126 Check_Arg_Is_Local_Name
(Arg1
);
18127 Check_Arg_Is_One_Of
(Arg2
,
18130 Name_By_Protected_Procedure
,
18133 -- Extract the name of the local procedure
18135 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18137 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
18138 -- primitive procedure of a synchronized tagged type.
18140 if Ekind
(Proc_Id
) = E_Procedure
18141 and then Is_Primitive
(Proc_Id
)
18142 and then Present
(First_Formal
(Proc_Id
))
18144 Typ
:= Etype
(First_Formal
(Proc_Id
));
18146 if Is_Tagged_Type
(Typ
)
18149 -- Check for a protected, a synchronized or a task interface
18151 ((Is_Interface
(Typ
)
18152 and then Is_Synchronized_Interface
(Typ
))
18154 -- Check for a protected type or a task type that implements
18158 (Is_Concurrent_Record_Type
(Typ
)
18159 and then Present
(Interfaces
(Typ
)))
18161 -- In analysis-only mode, examine original protected type
18164 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
18165 and then Present
(Interface_List
(Parent
(Typ
))))
18167 -- Check for a private record extension with keyword
18171 (Ekind
(Typ
) in E_Record_Type_With_Private
18172 | E_Record_Subtype_With_Private
18173 and then Synchronized_Present
(Parent
(Typ
))))
18178 ("controlling formal must be of synchronized tagged type",
18182 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
18183 -- By_Protected_Procedure to the primitive procedure of a task
18186 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
18187 and then Is_Interface
(Typ
)
18188 and then Is_Task_Interface
(Typ
)
18191 ("implementation kind By_Protected_Procedure cannot be "
18192 & "applied to a task interface primitive", Arg2
);
18195 -- Procedures declared inside a protected type must be accepted
18197 elsif Ekind
(Proc_Id
) = E_Procedure
18198 and then Is_Protected_Type
(Scope
(Proc_Id
))
18202 -- The first argument is not a primitive procedure
18206 ("pragma % must be applied to a primitive procedure", Arg1
);
18209 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
18210 -- By_Protected_Procedure to a procedure that has aspect Yield
18212 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
18213 and then Has_Yield_Aspect
(Proc_Id
)
18216 ("implementation kind By_Protected_Procedure cannot be "
18217 & "applied to entities with aspect 'Yield", Arg2
);
18220 Record_Rep_Item
(Proc_Id
, N
);
18223 ----------------------
18224 -- Implicit_Packing --
18225 ----------------------
18227 -- pragma Implicit_Packing;
18229 when Pragma_Implicit_Packing
=>
18231 Check_Arg_Count
(0);
18232 Implicit_Packing
:= True;
18239 -- [Convention =>] convention_IDENTIFIER,
18240 -- [Entity =>] LOCAL_NAME
18241 -- [, [External_Name =>] static_string_EXPRESSION ]
18242 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18244 when Pragma_Import
=>
18245 Check_Ada_83_Warning
;
18249 Name_External_Name
,
18252 Check_At_Least_N_Arguments
(2);
18253 Check_At_Most_N_Arguments
(4);
18254 Process_Import_Or_Interface
;
18256 ---------------------
18257 -- Import_Function --
18258 ---------------------
18260 -- pragma Import_Function (
18261 -- [Internal =>] LOCAL_NAME,
18262 -- [, [External =>] EXTERNAL_SYMBOL]
18263 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18264 -- [, [Result_Type =>] SUBTYPE_MARK]
18265 -- [, [Mechanism =>] MECHANISM]
18266 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
18268 -- EXTERNAL_SYMBOL ::=
18270 -- | static_string_EXPRESSION
18272 -- PARAMETER_TYPES ::=
18274 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18276 -- TYPE_DESIGNATOR ::=
18278 -- | subtype_Name ' Access
18282 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18284 -- MECHANISM_ASSOCIATION ::=
18285 -- [formal_parameter_NAME =>] MECHANISM_NAME
18287 -- MECHANISM_NAME ::=
18291 when Pragma_Import_Function
=> Import_Function
: declare
18292 Args
: Args_List
(1 .. 6);
18293 Names
: constant Name_List
(1 .. 6) := (
18296 Name_Parameter_Types
,
18299 Name_Result_Mechanism
);
18301 Internal
: Node_Id
renames Args
(1);
18302 External
: Node_Id
renames Args
(2);
18303 Parameter_Types
: Node_Id
renames Args
(3);
18304 Result_Type
: Node_Id
renames Args
(4);
18305 Mechanism
: Node_Id
renames Args
(5);
18306 Result_Mechanism
: Node_Id
renames Args
(6);
18310 Gather_Associations
(Names
, Args
);
18311 Process_Extended_Import_Export_Subprogram_Pragma
(
18312 Arg_Internal
=> Internal
,
18313 Arg_External
=> External
,
18314 Arg_Parameter_Types
=> Parameter_Types
,
18315 Arg_Result_Type
=> Result_Type
,
18316 Arg_Mechanism
=> Mechanism
,
18317 Arg_Result_Mechanism
=> Result_Mechanism
);
18318 end Import_Function
;
18320 -------------------
18321 -- Import_Object --
18322 -------------------
18324 -- pragma Import_Object (
18325 -- [Internal =>] LOCAL_NAME
18326 -- [, [External =>] EXTERNAL_SYMBOL]
18327 -- [, [Size =>] EXTERNAL_SYMBOL]);
18329 -- EXTERNAL_SYMBOL ::=
18331 -- | static_string_EXPRESSION
18333 when Pragma_Import_Object
=> Import_Object
: declare
18334 Args
: Args_List
(1 .. 3);
18335 Names
: constant Name_List
(1 .. 3) := (
18340 Internal
: Node_Id
renames Args
(1);
18341 External
: Node_Id
renames Args
(2);
18342 Size
: Node_Id
renames Args
(3);
18346 Gather_Associations
(Names
, Args
);
18347 Process_Extended_Import_Export_Object_Pragma
(
18348 Arg_Internal
=> Internal
,
18349 Arg_External
=> External
,
18353 ----------------------
18354 -- Import_Procedure --
18355 ----------------------
18357 -- pragma Import_Procedure (
18358 -- [Internal =>] LOCAL_NAME
18359 -- [, [External =>] EXTERNAL_SYMBOL]
18360 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18361 -- [, [Mechanism =>] MECHANISM]);
18363 -- EXTERNAL_SYMBOL ::=
18365 -- | static_string_EXPRESSION
18367 -- PARAMETER_TYPES ::=
18369 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18371 -- TYPE_DESIGNATOR ::=
18373 -- | subtype_Name ' Access
18377 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18379 -- MECHANISM_ASSOCIATION ::=
18380 -- [formal_parameter_NAME =>] MECHANISM_NAME
18382 -- MECHANISM_NAME ::=
18386 when Pragma_Import_Procedure
=> Import_Procedure
: declare
18387 Args
: Args_List
(1 .. 4);
18388 Names
: constant Name_List
(1 .. 4) := (
18391 Name_Parameter_Types
,
18394 Internal
: Node_Id
renames Args
(1);
18395 External
: Node_Id
renames Args
(2);
18396 Parameter_Types
: Node_Id
renames Args
(3);
18397 Mechanism
: Node_Id
renames Args
(4);
18401 Gather_Associations
(Names
, Args
);
18402 Process_Extended_Import_Export_Subprogram_Pragma
(
18403 Arg_Internal
=> Internal
,
18404 Arg_External
=> External
,
18405 Arg_Parameter_Types
=> Parameter_Types
,
18406 Arg_Mechanism
=> Mechanism
);
18407 end Import_Procedure
;
18409 -----------------------------
18410 -- Import_Valued_Procedure --
18411 -----------------------------
18413 -- pragma Import_Valued_Procedure (
18414 -- [Internal =>] LOCAL_NAME
18415 -- [, [External =>] EXTERNAL_SYMBOL]
18416 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18417 -- [, [Mechanism =>] MECHANISM]);
18419 -- EXTERNAL_SYMBOL ::=
18421 -- | static_string_EXPRESSION
18423 -- PARAMETER_TYPES ::=
18425 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18427 -- TYPE_DESIGNATOR ::=
18429 -- | subtype_Name ' Access
18433 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18435 -- MECHANISM_ASSOCIATION ::=
18436 -- [formal_parameter_NAME =>] MECHANISM_NAME
18438 -- MECHANISM_NAME ::=
18442 when Pragma_Import_Valued_Procedure
=>
18443 Import_Valued_Procedure
: declare
18444 Args
: Args_List
(1 .. 4);
18445 Names
: constant Name_List
(1 .. 4) := (
18448 Name_Parameter_Types
,
18451 Internal
: Node_Id
renames Args
(1);
18452 External
: Node_Id
renames Args
(2);
18453 Parameter_Types
: Node_Id
renames Args
(3);
18454 Mechanism
: Node_Id
renames Args
(4);
18458 Gather_Associations
(Names
, Args
);
18459 Process_Extended_Import_Export_Subprogram_Pragma
(
18460 Arg_Internal
=> Internal
,
18461 Arg_External
=> External
,
18462 Arg_Parameter_Types
=> Parameter_Types
,
18463 Arg_Mechanism
=> Mechanism
);
18464 end Import_Valued_Procedure
;
18470 -- pragma Independent (LOCAL_NAME);
18472 when Pragma_Independent
=>
18473 Process_Atomic_Independent_Shared_Volatile
;
18475 ----------------------------
18476 -- Independent_Components --
18477 ----------------------------
18479 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
18481 when Pragma_Independent_Components
=> Independent_Components
: declare
18488 Check_Ada_83_Warning
;
18490 Check_No_Identifiers
;
18491 Check_Arg_Count
(1);
18492 Check_Arg_Is_Local_Name
(Arg1
);
18493 E_Id
:= Get_Pragma_Arg
(Arg1
);
18495 if Etype
(E_Id
) = Any_Type
then
18499 E
:= Entity
(E_Id
);
18501 -- A record type with a self-referential component of anonymous
18502 -- access type is given an incomplete view in order to handle the
18505 -- type Rec is record
18506 -- Self : access Rec;
18512 -- type Ptr is access Rec;
18513 -- type Rec is record
18517 -- Since the incomplete view is now the initial view of the type,
18518 -- the argument of the pragma will reference the incomplete view,
18519 -- but this view is illegal according to the semantics of the
18522 -- Obtain the full view of an internally-generated incomplete type
18523 -- only. This way an attempt to associate the pragma with a source
18524 -- incomplete type is still caught.
18526 if Ekind
(E
) = E_Incomplete_Type
18527 and then not Comes_From_Source
(E
)
18528 and then Present
(Full_View
(E
))
18530 E
:= Full_View
(E
);
18533 -- A pragma that applies to a Ghost entity becomes Ghost for the
18534 -- purposes of legality checks and removal of ignored Ghost code.
18536 Mark_Ghost_Pragma
(N
, E
);
18538 -- Check duplicate before we chain ourselves
18540 Check_Duplicate_Pragma
(E
);
18542 -- Check appropriate entity
18544 if Rep_Item_Too_Early
(E
, N
)
18546 Rep_Item_Too_Late
(E
, N
)
18551 D
:= Declaration_Node
(E
);
18553 -- The flag is set on the base type, or on the object
18555 if Nkind
(D
) = N_Full_Type_Declaration
18556 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
18558 Set_Has_Independent_Components
(Base_Type
(E
));
18559 Record_Independence_Check
(N
, Base_Type
(E
));
18561 -- For record type, set all components independent
18563 if Is_Record_Type
(E
) then
18564 C
:= First_Component
(E
);
18565 while Present
(C
) loop
18566 Set_Is_Independent
(C
);
18567 Next_Component
(C
);
18571 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
18572 and then Nkind
(D
) = N_Object_Declaration
18573 and then Nkind
(Object_Definition
(D
)) =
18574 N_Constrained_Array_Definition
18576 Set_Has_Independent_Components
(E
);
18577 Record_Independence_Check
(N
, E
);
18580 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
18582 end Independent_Components
;
18584 -----------------------
18585 -- Initial_Condition --
18586 -----------------------
18588 -- pragma Initial_Condition (boolean_EXPRESSION);
18590 -- Characteristics:
18592 -- * Analysis - The annotation undergoes initial checks to verify
18593 -- the legal placement and context. Secondary checks preanalyze the
18596 -- Analyze_Initial_Condition_In_Decl_Part
18598 -- * Expansion - The annotation is expanded during the expansion of
18599 -- the package body whose declaration is subject to the annotation
18602 -- Expand_Pragma_Initial_Condition
18604 -- * Template - The annotation utilizes the generic template of the
18605 -- related package declaration.
18607 -- * Globals - Capture of global references must occur after full
18610 -- * Instance - The annotation is instantiated automatically when
18611 -- the related generic package is instantiated.
18613 when Pragma_Initial_Condition
=> Initial_Condition
: declare
18614 Pack_Decl
: Node_Id
;
18615 Pack_Id
: Entity_Id
;
18619 Check_No_Identifiers
;
18620 Check_Arg_Count
(1);
18622 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18624 if Nkind
(Pack_Decl
) not in
18625 N_Generic_Package_Declaration | N_Package_Declaration
18630 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18632 -- A pragma that applies to a Ghost entity becomes Ghost for the
18633 -- purposes of legality checks and removal of ignored Ghost code.
18635 Mark_Ghost_Pragma
(N
, Pack_Id
);
18637 -- Chain the pragma on the contract for further processing by
18638 -- Analyze_Initial_Condition_In_Decl_Part.
18640 Add_Contract_Item
(N
, Pack_Id
);
18642 -- The legality checks of pragmas Abstract_State, Initializes, and
18643 -- Initial_Condition are affected by the SPARK mode in effect. In
18644 -- addition, these three pragmas are subject to an inherent order:
18646 -- 1) Abstract_State
18648 -- 3) Initial_Condition
18650 -- Analyze all these pragmas in the order outlined above
18652 Analyze_If_Present
(Pragma_SPARK_Mode
);
18653 Analyze_If_Present
(Pragma_Abstract_State
);
18654 Analyze_If_Present
(Pragma_Initializes
);
18655 end Initial_Condition
;
18657 ------------------------
18658 -- Initialize_Scalars --
18659 ------------------------
18661 -- pragma Initialize_Scalars
18662 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
18664 -- TYPE_VALUE_PAIR ::=
18665 -- SCALAR_TYPE => static_EXPRESSION
18671 -- | Long_Long_Float
18683 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
18684 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
18685 -- This collection holds the individual pairs which specify the
18686 -- invalid values of their respective scalar types.
18688 procedure Analyze_Float_Value
18689 (Scal_Typ
: Float_Scalar_Id
;
18690 Val_Expr
: Node_Id
);
18691 -- Analyze a type value pair associated with float type Scal_Typ
18692 -- and expression Val_Expr.
18694 procedure Analyze_Integer_Value
18695 (Scal_Typ
: Integer_Scalar_Id
;
18696 Val_Expr
: Node_Id
);
18697 -- Analyze a type value pair associated with integer type Scal_Typ
18698 -- and expression Val_Expr.
18700 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
18701 -- Analyze type value pair Pair
18703 -------------------------
18704 -- Analyze_Float_Value --
18705 -------------------------
18707 procedure Analyze_Float_Value
18708 (Scal_Typ
: Float_Scalar_Id
;
18709 Val_Expr
: Node_Id
)
18712 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
18714 if Is_OK_Static_Expression
(Val_Expr
) then
18715 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
18718 Error_Msg_Name_1
:= Scal_Typ
;
18719 Error_Msg_N
("value for type % must be static", Val_Expr
);
18721 end Analyze_Float_Value
;
18723 ---------------------------
18724 -- Analyze_Integer_Value --
18725 ---------------------------
18727 procedure Analyze_Integer_Value
18728 (Scal_Typ
: Integer_Scalar_Id
;
18729 Val_Expr
: Node_Id
)
18732 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
18734 if (Scal_Typ
= Name_Signed_128
18735 or else Scal_Typ
= Name_Unsigned_128
)
18736 and then Ttypes
.System_Max_Integer_Size
< 128
18738 Error_Msg_Name_1
:= Scal_Typ
;
18739 Error_Msg_N
("value cannot be set for type %", Val_Expr
);
18741 elsif Is_OK_Static_Expression
(Val_Expr
) then
18742 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
18745 Error_Msg_Name_1
:= Scal_Typ
;
18746 Error_Msg_N
("value for type % must be static", Val_Expr
);
18748 end Analyze_Integer_Value
;
18750 -----------------------------
18751 -- Analyze_Type_Value_Pair --
18752 -----------------------------
18754 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
18755 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
18756 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
18757 Prev_Pair
: Node_Id
;
18760 if Scal_Typ
in Scalar_Id
then
18761 Prev_Pair
:= Seen
(Scal_Typ
);
18763 -- Prevent multiple attempts to set a value for a scalar
18766 if Present
(Prev_Pair
) then
18767 Error_Msg_Name_1
:= Scal_Typ
;
18769 ("cannot specify multiple invalid values for type %",
18772 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18773 Error_Msg_N
("previous value set #", Pair
);
18775 -- Ignore the effects of the pair, but do not halt the
18776 -- analysis of the pragma altogether.
18780 -- Otherwise capture the first pair for this scalar type
18783 Seen
(Scal_Typ
) := Pair
;
18786 if Scal_Typ
in Float_Scalar_Id
then
18787 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18789 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18790 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18793 -- Otherwise the scalar family is illegal
18796 Error_Msg_Name_1
:= Pname
;
18798 ("argument of pragma % must denote valid scalar family",
18801 end Analyze_Type_Value_Pair
;
18805 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18808 -- Start of processing for Do_Initialize_Scalars
18812 Check_Valid_Configuration_Pragma
;
18813 Check_Restriction
(No_Initialize_Scalars
, N
);
18815 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18818 if Restriction_Active
(No_Initialize_Scalars
) then
18821 -- Initialize_Scalars creates false positives in CodePeer, and
18822 -- incorrect negative results in GNATprove mode, so ignore this
18823 -- pragma in these modes.
18825 elsif CodePeer_Mode
or GNATprove_Mode
then
18828 -- Otherwise analyze the pragma
18831 if Present
(Pairs
) then
18833 -- Install Standard in order to provide access to primitive
18834 -- types in case the expressions contain attributes such as
18837 Push_Scope
(Standard_Standard
);
18839 Pair
:= First
(Pairs
);
18840 while Present
(Pair
) loop
18841 Analyze_Type_Value_Pair
(Pair
);
18850 Init_Or_Norm_Scalars
:= True;
18851 Initialize_Scalars
:= True;
18853 end Do_Initialize_Scalars
;
18859 -- pragma Initializes (INITIALIZATION_LIST);
18861 -- INITIALIZATION_LIST ::=
18863 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18865 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18870 -- | (INPUT {, INPUT})
18874 -- Characteristics:
18876 -- * Analysis - The annotation undergoes initial checks to verify
18877 -- the legal placement and context. Secondary checks preanalyze the
18880 -- Analyze_Initializes_In_Decl_Part
18882 -- * Expansion - None.
18884 -- * Template - The annotation utilizes the generic template of the
18885 -- related package declaration.
18887 -- * Globals - Capture of global references must occur after full
18890 -- * Instance - The annotation is instantiated automatically when
18891 -- the related generic package is instantiated.
18893 when Pragma_Initializes
=> Initializes
: declare
18894 Pack_Decl
: Node_Id
;
18895 Pack_Id
: Entity_Id
;
18899 Check_No_Identifiers
;
18900 Check_Arg_Count
(1);
18902 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18904 if Nkind
(Pack_Decl
) not in
18905 N_Generic_Package_Declaration | N_Package_Declaration
18910 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18912 -- A pragma that applies to a Ghost entity becomes Ghost for the
18913 -- purposes of legality checks and removal of ignored Ghost code.
18915 Mark_Ghost_Pragma
(N
, Pack_Id
);
18916 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18918 -- Chain the pragma on the contract for further processing by
18919 -- Analyze_Initializes_In_Decl_Part.
18921 Add_Contract_Item
(N
, Pack_Id
);
18923 -- The legality checks of pragmas Abstract_State, Initializes, and
18924 -- Initial_Condition are affected by the SPARK mode in effect. In
18925 -- addition, these three pragmas are subject to an inherent order:
18927 -- 1) Abstract_State
18929 -- 3) Initial_Condition
18931 -- Analyze all these pragmas in the order outlined above
18933 Analyze_If_Present
(Pragma_SPARK_Mode
);
18934 Analyze_If_Present
(Pragma_Abstract_State
);
18935 Analyze_If_Present
(Pragma_Initial_Condition
);
18942 -- pragma Inline ( NAME {, NAME} );
18944 when Pragma_Inline
=>
18946 -- Pragma always active unless in GNATprove mode. It is disabled
18947 -- in GNATprove mode because frontend inlining is applied
18948 -- independently of pragmas Inline and Inline_Always for
18949 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18952 if not GNATprove_Mode
then
18954 -- Inline status is Enabled if option -gnatn is specified.
18955 -- However this status determines only the value of the
18956 -- Is_Inlined flag on the subprogram and does not prevent
18957 -- the pragma itself from being recorded for later use,
18958 -- in particular for a later modification of Is_Inlined
18959 -- independently of the -gnatn option.
18961 -- In other words, if -gnatn is specified for a unit, then
18962 -- all Inline pragmas processed for the compilation of this
18963 -- unit, including those in the spec of other units, are
18964 -- activated, so subprograms will be inlined across units.
18966 -- If -gnatn is not specified, no Inline pragma is activated
18967 -- here, which means that subprograms will not be inlined
18968 -- across units. The Is_Inlined flag will nevertheless be
18969 -- set later when bodies are analyzed, so subprograms will
18970 -- be inlined within the unit.
18972 if Inline_Active
then
18973 Process_Inline
(Enabled
);
18975 Process_Inline
(Disabled
);
18979 -------------------
18980 -- Inline_Always --
18981 -------------------
18983 -- pragma Inline_Always ( NAME {, NAME} );
18985 when Pragma_Inline_Always
=>
18988 -- Pragma always active unless in CodePeer mode or GNATprove
18989 -- mode. It is disabled in CodePeer mode because inlining is
18990 -- not helpful, and enabling it caused walk order issues. It
18991 -- is disabled in GNATprove mode because frontend inlining is
18992 -- applied independently of pragmas Inline and Inline_Always for
18993 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18996 if not CodePeer_Mode
and not GNATprove_Mode
then
18997 Process_Inline
(Enabled
);
19000 --------------------
19001 -- Inline_Generic --
19002 --------------------
19004 -- pragma Inline_Generic (NAME {, NAME});
19006 when Pragma_Inline_Generic
=>
19008 Process_Generic_List
;
19010 ----------------------
19011 -- Inspection_Point --
19012 ----------------------
19014 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
19016 when Pragma_Inspection_Point
=> Inspection_Point
: declare
19023 if Arg_Count
> 0 then
19026 Exp
:= Get_Pragma_Arg
(Arg
);
19029 if not Is_Entity_Name
(Exp
)
19030 or else not Is_Object
(Entity
(Exp
))
19032 Error_Pragma_Arg
("object name required", Arg
);
19036 exit when No
(Arg
);
19039 end Inspection_Point
;
19045 -- pragma Interface (
19046 -- [ Convention =>] convention_IDENTIFIER,
19047 -- [ Entity =>] LOCAL_NAME
19048 -- [, [External_Name =>] static_string_EXPRESSION ]
19049 -- [, [Link_Name =>] static_string_EXPRESSION ]);
19051 when Pragma_Interface
=>
19056 Name_External_Name
,
19058 Check_At_Least_N_Arguments
(2);
19059 Check_At_Most_N_Arguments
(4);
19060 Process_Import_Or_Interface
;
19062 -- In Ada 2005, the permission to use Interface (a reserved word)
19063 -- as a pragma name is considered an obsolescent feature, and this
19064 -- pragma was already obsolescent in Ada 95.
19066 if Ada_Version
>= Ada_95
then
19068 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
19070 if Warn_On_Obsolescent_Feature
then
19072 ("pragma Interface is an obsolescent feature?j?", N
);
19074 ("|use pragma Import instead?j?", N
);
19078 --------------------
19079 -- Interface_Name --
19080 --------------------
19082 -- pragma Interface_Name (
19083 -- [ Entity =>] LOCAL_NAME
19084 -- [,[External_Name =>] static_string_EXPRESSION ]
19085 -- [,[Link_Name =>] static_string_EXPRESSION ]);
19087 when Pragma_Interface_Name
=> Interface_Name
: declare
19089 Def_Id
: Entity_Id
;
19090 Hom_Id
: Entity_Id
;
19096 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
19097 Check_At_Least_N_Arguments
(2);
19098 Check_At_Most_N_Arguments
(3);
19099 Id
:= Get_Pragma_Arg
(Arg1
);
19102 -- This is obsolete from Ada 95 on, but it is an implementation
19103 -- defined pragma, so we do not consider that it violates the
19104 -- restriction (No_Obsolescent_Features).
19106 if Ada_Version
>= Ada_95
then
19107 if Warn_On_Obsolescent_Feature
then
19109 ("pragma Interface_Name is an obsolescent feature?j?", N
);
19111 ("|use pragma Import instead?j?", N
);
19115 if not Is_Entity_Name
(Id
) then
19117 ("first argument for pragma% must be entity name", Arg1
);
19118 elsif Etype
(Id
) = Any_Type
then
19121 Def_Id
:= Entity
(Id
);
19124 -- Special DEC-compatible processing for the object case, forces
19125 -- object to be imported.
19127 if Ekind
(Def_Id
) = E_Variable
then
19128 Kill_Size_Check_Code
(Def_Id
);
19129 Note_Possible_Modification
(Id
, Sure
=> False);
19131 -- Initialization is not allowed for imported variable
19133 if Present
(Expression
(Parent
(Def_Id
)))
19134 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
19136 Error_Msg_Sloc
:= Sloc
(Def_Id
);
19138 ("no initialization allowed for declaration of& #",
19142 -- For compatibility, support VADS usage of providing both
19143 -- pragmas Interface and Interface_Name to obtain the effect
19144 -- of a single Import pragma.
19146 if Is_Imported
(Def_Id
)
19147 and then Present
(First_Rep_Item
(Def_Id
))
19148 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
19149 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
19154 Set_Imported
(Def_Id
);
19157 Set_Is_Public
(Def_Id
);
19158 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
19161 -- Otherwise must be subprogram
19163 elsif not Is_Subprogram
(Def_Id
) then
19165 ("argument of pragma% is not subprogram", Arg1
);
19168 Check_At_Most_N_Arguments
(3);
19172 -- Loop through homonyms
19175 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
19177 if Is_Imported
(Def_Id
) then
19178 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
19182 exit when From_Aspect_Specification
(N
);
19183 Hom_Id
:= Homonym
(Hom_Id
);
19185 exit when No
(Hom_Id
)
19186 or else Scope
(Hom_Id
) /= Current_Scope
;
19191 ("argument of pragma% is not imported subprogram",
19195 end Interface_Name
;
19197 -----------------------
19198 -- Interrupt_Handler --
19199 -----------------------
19201 -- pragma Interrupt_Handler (handler_NAME);
19203 when Pragma_Interrupt_Handler
=>
19204 Check_Ada_83_Warning
;
19205 Check_Arg_Count
(1);
19206 Check_No_Identifiers
;
19208 if No_Run_Time_Mode
then
19209 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
19211 Check_Interrupt_Or_Attach_Handler
;
19212 Process_Interrupt_Or_Attach_Handler
;
19215 ------------------------
19216 -- Interrupt_Priority --
19217 ------------------------
19219 -- pragma Interrupt_Priority [(EXPRESSION)];
19221 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
19222 P
: constant Node_Id
:= Parent
(N
);
19227 Check_Ada_83_Warning
;
19229 if Arg_Count
/= 0 then
19230 Arg
:= Get_Pragma_Arg
(Arg1
);
19231 Check_Arg_Count
(1);
19232 Check_No_Identifiers
;
19234 -- The expression must be analyzed in the special manner
19235 -- described in "Handling of Default and Per-Object
19236 -- Expressions" in sem.ads.
19238 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
19241 if Nkind
(P
) not in N_Task_Definition | N_Protected_Definition
then
19245 Ent
:= Defining_Identifier
(Parent
(P
));
19247 -- Check duplicate pragma before we chain the pragma in the Rep
19248 -- Item chain of Ent.
19250 Check_Duplicate_Pragma
(Ent
);
19251 Record_Rep_Item
(Ent
, N
);
19253 -- Check the No_Task_At_Interrupt_Priority restriction
19255 if Nkind
(P
) = N_Task_Definition
then
19256 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
19259 end Interrupt_Priority
;
19261 ---------------------
19262 -- Interrupt_State --
19263 ---------------------
19265 -- pragma Interrupt_State (
19266 -- [Name =>] INTERRUPT_ID,
19267 -- [State =>] INTERRUPT_STATE);
19269 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
19270 -- INTERRUPT_STATE => System | Runtime | User
19272 -- Note: if the interrupt id is given as an identifier, then it must
19273 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
19274 -- given as a static integer expression which must be in the range of
19275 -- Ada.Interrupts.Interrupt_ID.
19277 when Pragma_Interrupt_State
=> Interrupt_State
: declare
19278 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
19279 -- This is the entity Ada.Interrupts.Interrupt_ID;
19281 State_Type
: Character;
19282 -- Set to 's'/'r'/'u' for System/Runtime/User
19285 -- Index to entry in Interrupt_States table
19288 -- Value of interrupt
19290 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19291 -- The first argument to the pragma
19293 Int_Ent
: Entity_Id
;
19294 -- Interrupt entity in Ada.Interrupts.Names
19298 Check_Arg_Order
((Name_Name
, Name_State
));
19299 Check_Arg_Count
(2);
19301 Check_Optional_Identifier
(Arg1
, Name_Name
);
19302 Check_Optional_Identifier
(Arg2
, Name_State
);
19303 Check_Arg_Is_Identifier
(Arg2
);
19305 -- First argument is identifier
19307 if Nkind
(Arg1X
) = N_Identifier
then
19309 -- Search list of names in Ada.Interrupts.Names
19311 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
19313 if No
(Int_Ent
) then
19314 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
19316 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
19317 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
19321 Next_Entity
(Int_Ent
);
19324 -- First argument is not an identifier, so it must be a static
19325 -- expression of type Ada.Interrupts.Interrupt_ID.
19328 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
19329 Int_Val
:= Expr_Value
(Arg1X
);
19331 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
19333 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
19336 ("value not in range of type "
19337 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
19343 case Chars
(Get_Pragma_Arg
(Arg2
)) is
19344 when Name_Runtime
=> State_Type
:= 'r';
19345 when Name_System
=> State_Type
:= 's';
19346 when Name_User
=> State_Type
:= 'u';
19349 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
19352 -- Check if entry is already stored
19354 IST_Num
:= Interrupt_States
.First
;
19356 -- If entry not found, add it
19358 if IST_Num
> Interrupt_States
.Last
then
19359 Interrupt_States
.Append
19360 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
19361 Interrupt_State
=> State_Type
,
19362 Pragma_Loc
=> Loc
));
19365 -- Case of entry for the same entry
19367 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
19370 -- If state matches, done, no need to make redundant entry
19373 State_Type
= Interrupt_States
.Table
(IST_Num
).
19376 -- Otherwise if state does not match, error
19379 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
19381 ("state conflicts with that given #", Arg2
);
19384 IST_Num
:= IST_Num
+ 1;
19386 end Interrupt_State
;
19392 -- pragma Invariant
19393 -- ([Entity =>] type_LOCAL_NAME,
19394 -- [Check =>] EXPRESSION
19395 -- [,[Message =>] String_Expression]);
19397 when Pragma_Invariant
=> Invariant
: declare
19404 Check_At_Least_N_Arguments
(2);
19405 Check_At_Most_N_Arguments
(3);
19406 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19407 Check_Optional_Identifier
(Arg2
, Name_Check
);
19409 if Arg_Count
= 3 then
19410 Check_Optional_Identifier
(Arg3
, Name_Message
);
19411 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
19414 Check_Arg_Is_Local_Name
(Arg1
);
19416 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
19417 Find_Type
(Typ_Arg
);
19418 Typ
:= Entity
(Typ_Arg
);
19420 -- Nothing to do of the related type is erroneous in some way
19422 if Typ
= Any_Type
then
19425 -- AI12-0041: Invariants are allowed in interface types
19427 elsif Is_Interface
(Typ
) then
19430 -- An invariant must apply to a private type, or appear in the
19431 -- private part of a package spec and apply to a completion.
19432 -- a class-wide invariant can only appear on a private declaration
19433 -- or private extension, not a completion.
19435 -- A [class-wide] invariant may be associated a [limited] private
19436 -- type or a private extension.
19438 elsif Ekind
(Typ
) in E_Limited_Private_Type
19440 | E_Record_Type_With_Private
19444 -- A non-class-wide invariant may be associated with the full view
19445 -- of a [limited] private type or a private extension.
19447 elsif Has_Private_Declaration
(Typ
)
19448 and then not Class_Present
(N
)
19452 -- A class-wide invariant may appear on the partial view only
19454 elsif Class_Present
(N
) then
19456 ("pragma % only allowed for private type", Arg1
);
19458 -- A regular invariant may appear on both views
19462 ("pragma % only allowed for private type or corresponding "
19463 & "full view", Arg1
);
19466 -- An invariant associated with an abstract type (this includes
19467 -- interfaces) must be class-wide.
19469 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
19471 ("pragma % not allowed for abstract type", Arg1
);
19474 -- A pragma that applies to a Ghost entity becomes Ghost for the
19475 -- purposes of legality checks and removal of ignored Ghost code.
19477 Mark_Ghost_Pragma
(N
, Typ
);
19479 -- The pragma defines a type-specific invariant, the type is said
19480 -- to have invariants of its "own".
19482 Set_Has_Own_Invariants
(Base_Type
(Typ
));
19484 -- If the invariant is class-wide, then it can be inherited by
19485 -- derived or interface implementing types. The type is said to
19486 -- have "inheritable" invariants.
19488 if Class_Present
(N
) then
19489 Set_Has_Inheritable_Invariants
(Typ
);
19492 -- Chain the pragma on to the rep item chain, for processing when
19493 -- the type is frozen.
19495 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19497 -- Create the declaration of the invariant procedure that will
19498 -- verify the invariant at run time. Interfaces are treated as the
19499 -- partial view of a private type in order to achieve uniformity
19500 -- with the general case. As a result, an interface receives only
19501 -- a "partial" invariant procedure, which is never called.
19503 Build_Invariant_Procedure_Declaration
19505 Partial_Invariant
=> Is_Interface
(Typ
));
19512 -- pragma Keep_Names ([On => ] LOCAL_NAME);
19514 when Pragma_Keep_Names
=> Keep_Names
: declare
19519 Check_Arg_Count
(1);
19520 Check_Optional_Identifier
(Arg1
, Name_On
);
19521 Check_Arg_Is_Local_Name
(Arg1
);
19523 Arg
:= Get_Pragma_Arg
(Arg1
);
19526 if Etype
(Arg
) = Any_Type
then
19530 if not Is_Entity_Name
(Arg
)
19531 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
19534 ("pragma% requires a local enumeration type", Arg1
);
19537 Set_Discard_Names
(Entity
(Arg
), False);
19544 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
19546 when Pragma_License
=>
19549 -- Do not analyze pragma any further in CodePeer mode, to avoid
19550 -- extraneous errors in this implementation-dependent pragma,
19551 -- which has a different profile on other compilers.
19553 if CodePeer_Mode
then
19557 Check_Arg_Count
(1);
19558 Check_No_Identifiers
;
19559 Check_Valid_Configuration_Pragma
;
19560 Check_Arg_Is_Identifier
(Arg1
);
19563 Sind
: constant Source_File_Index
:=
19564 Source_Index
(Current_Sem_Unit
);
19567 case Chars
(Get_Pragma_Arg
(Arg1
)) is
19569 Set_License
(Sind
, GPL
);
19571 when Name_Modified_GPL
=>
19572 Set_License
(Sind
, Modified_GPL
);
19574 when Name_Restricted
=>
19575 Set_License
(Sind
, Restricted
);
19577 when Name_Unrestricted
=>
19578 Set_License
(Sind
, Unrestricted
);
19581 Error_Pragma_Arg
("invalid license name", Arg1
);
19589 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
19591 when Pragma_Link_With
=> Link_With
: declare
19597 if Operating_Mode
= Generate_Code
19598 and then In_Extended_Main_Source_Unit
(N
)
19600 Check_At_Least_N_Arguments
(1);
19601 Check_No_Identifiers
;
19602 Check_Is_In_Decl_Part_Or_Package_Spec
;
19603 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19607 while Present
(Arg
) loop
19608 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19610 -- Store argument, converting sequences of spaces to a
19611 -- single null character (this is one of the differences
19612 -- in processing between Link_With and Linker_Options).
19614 Arg_Store
: declare
19615 C
: constant Char_Code
:= Get_Char_Code
(' ');
19616 S
: constant String_Id
:=
19617 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
19618 L
: constant Nat
:= String_Length
(S
);
19621 procedure Skip_Spaces
;
19622 -- Advance F past any spaces
19628 procedure Skip_Spaces
is
19630 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
19635 -- Start of processing for Arg_Store
19638 Skip_Spaces
; -- skip leading spaces
19640 -- Loop through characters, changing any embedded
19641 -- sequence of spaces to a single null character (this
19642 -- is how Link_With/Linker_Options differ)
19645 if Get_String_Char
(S
, F
) = C
then
19648 Store_String_Char
(ASCII
.NUL
);
19651 Store_String_Char
(Get_String_Char
(S
, F
));
19659 if Present
(Arg
) then
19660 Store_String_Char
(ASCII
.NUL
);
19664 Store_Linker_Option_String
(End_String
);
19672 -- pragma Linker_Alias (
19673 -- [Entity =>] LOCAL_NAME
19674 -- [Target =>] static_string_EXPRESSION);
19676 when Pragma_Linker_Alias
=>
19678 Check_Arg_Order
((Name_Entity
, Name_Target
));
19679 Check_Arg_Count
(2);
19680 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19681 Check_Optional_Identifier
(Arg2
, Name_Target
);
19682 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19683 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19685 -- The only processing required is to link this item on to the
19686 -- list of rep items for the given entity. This is accomplished
19687 -- by the call to Rep_Item_Too_Late (when no error is detected
19688 -- and False is returned).
19690 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
19693 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19696 ------------------------
19697 -- Linker_Constructor --
19698 ------------------------
19700 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19702 -- Code is shared with Linker_Destructor
19704 -----------------------
19705 -- Linker_Destructor --
19706 -----------------------
19708 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19710 when Pragma_Linker_Constructor
19711 | Pragma_Linker_Destructor
19713 Linker_Constructor
: declare
19719 Check_Arg_Count
(1);
19720 Check_No_Identifiers
;
19721 Check_Arg_Is_Local_Name
(Arg1
);
19722 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
19724 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
19726 if not Is_Library_Level_Entity
(Proc
) then
19728 ("argument for pragma% must be library level entity", Arg1
);
19731 -- The only processing required is to link this item on to the
19732 -- list of rep items for the given entity. This is accomplished
19733 -- by the call to Rep_Item_Too_Late (when no error is detected
19734 -- and False is returned).
19736 if Rep_Item_Too_Late
(Proc
, N
) then
19739 Set_Has_Gigi_Rep_Item
(Proc
);
19741 end Linker_Constructor
;
19743 --------------------
19744 -- Linker_Options --
19745 --------------------
19747 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19749 when Pragma_Linker_Options
=> Linker_Options
: declare
19753 Check_Ada_83_Warning
;
19754 Check_No_Identifiers
;
19755 Check_Arg_Count
(1);
19756 Check_Is_In_Decl_Part_Or_Package_Spec
;
19757 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19758 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
19761 while Present
(Arg
) loop
19762 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19763 Store_String_Char
(ASCII
.NUL
);
19765 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19769 if Operating_Mode
= Generate_Code
19770 and then In_Extended_Main_Source_Unit
(N
)
19772 Store_Linker_Option_String
(End_String
);
19774 end Linker_Options
;
19776 --------------------
19777 -- Linker_Section --
19778 --------------------
19780 -- pragma Linker_Section (
19781 -- [Entity =>] LOCAL_NAME
19782 -- [Section =>] static_string_EXPRESSION);
19784 when Pragma_Linker_Section
=> Linker_Section
: declare
19789 Ghost_Error_Posted
: Boolean := False;
19790 -- Flag set when an error concerning the illegal mix of Ghost and
19791 -- non-Ghost subprograms is emitted.
19793 Ghost_Id
: Entity_Id
:= Empty
;
19794 -- The entity of the first Ghost subprogram encountered while
19795 -- processing the arguments of the pragma.
19799 Check_Arg_Order
((Name_Entity
, Name_Section
));
19800 Check_Arg_Count
(2);
19801 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19802 Check_Optional_Identifier
(Arg2
, Name_Section
);
19803 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19804 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19806 -- Check kind of entity
19808 Arg
:= Get_Pragma_Arg
(Arg1
);
19809 Ent
:= Entity
(Arg
);
19811 case Ekind
(Ent
) is
19813 -- Objects (constants and variables) and types. For these cases
19814 -- all we need to do is to set the Linker_Section_pragma field,
19815 -- checking that we do not have a duplicate.
19821 LPE
:= Linker_Section_Pragma
(Ent
);
19823 if Present
(LPE
) then
19824 Error_Msg_Sloc
:= Sloc
(LPE
);
19826 ("Linker_Section already specified for &#", Arg1
, Ent
);
19829 Set_Linker_Section_Pragma
(Ent
, N
);
19831 -- A pragma that applies to a Ghost entity becomes Ghost for
19832 -- the purposes of legality checks and removal of ignored
19835 Mark_Ghost_Pragma
(N
, Ent
);
19839 when Subprogram_Kind
=>
19841 -- Aspect case, entity already set
19843 if From_Aspect_Specification
(N
) then
19844 Set_Linker_Section_Pragma
19845 (Entity
(Corresponding_Aspect
(N
)), N
);
19847 -- Propagate it to its ultimate aliased entity to
19848 -- facilitate the backend processing this attribute
19849 -- in instantiations of generic subprograms.
19851 if Present
(Alias
(Entity
(Corresponding_Aspect
(N
))))
19853 Set_Linker_Section_Pragma
19855 (Entity
(Corresponding_Aspect
(N
))), N
);
19858 -- Pragma case, we must climb the homonym chain, but skip
19859 -- any for which the linker section is already set.
19863 if No
(Linker_Section_Pragma
(Ent
)) then
19864 Set_Linker_Section_Pragma
(Ent
, N
);
19866 -- Propagate it to its ultimate aliased entity to
19867 -- facilitate the backend processing this attribute
19868 -- in instantiations of generic subprograms.
19870 if Present
(Alias
(Ent
)) then
19871 Set_Linker_Section_Pragma
19872 (Ultimate_Alias
(Ent
), N
);
19875 -- A pragma that applies to a Ghost entity becomes
19876 -- Ghost for the purposes of legality checks and
19877 -- removal of ignored Ghost code.
19879 Mark_Ghost_Pragma
(N
, Ent
);
19881 -- Capture the entity of the first Ghost subprogram
19882 -- being processed for error detection purposes.
19884 if Is_Ghost_Entity
(Ent
) then
19885 if No
(Ghost_Id
) then
19889 -- Otherwise the subprogram is non-Ghost. It is
19890 -- illegal to mix references to Ghost and non-Ghost
19891 -- entities (SPARK RM 6.9).
19893 elsif Present
(Ghost_Id
)
19894 and then not Ghost_Error_Posted
19896 Ghost_Error_Posted
:= True;
19898 Error_Msg_Name_1
:= Pname
;
19900 ("pragma % cannot mention ghost and "
19901 & "non-ghost subprograms", N
);
19903 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19905 ("\& # declared as ghost", N
, Ghost_Id
);
19907 Error_Msg_Sloc
:= Sloc
(Ent
);
19909 ("\& # declared as non-ghost", N
, Ent
);
19913 Ent
:= Homonym
(Ent
);
19915 or else Scope
(Ent
) /= Current_Scope
;
19919 -- All other cases are illegal
19923 ("pragma% applies only to objects, subprograms, and types",
19926 end Linker_Section
;
19932 -- pragma List (On | Off)
19934 -- There is nothing to do here, since we did all the processing for
19935 -- this pragma in Par.Prag (so that it works properly even in syntax
19938 when Pragma_List
=>
19945 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19947 when Pragma_Lock_Free
=> Lock_Free
: declare
19948 P
: constant Node_Id
:= Parent
(N
);
19954 Check_No_Identifiers
;
19955 Check_At_Most_N_Arguments
(1);
19957 -- Protected definition case
19959 if Nkind
(P
) = N_Protected_Definition
then
19960 Ent
:= Defining_Identifier
(Parent
(P
));
19964 if Arg_Count
= 1 then
19965 Arg
:= Get_Pragma_Arg
(Arg1
);
19966 Val
:= Is_True
(Static_Boolean
(Arg
));
19968 -- No arguments (expression is considered to be True)
19974 -- Check duplicate pragma before we chain the pragma in the Rep
19975 -- Item chain of Ent.
19977 Check_Duplicate_Pragma
(Ent
);
19978 Record_Rep_Item
(Ent
, N
);
19979 Set_Uses_Lock_Free
(Ent
, Val
);
19981 -- Anything else is incorrect placement
19988 --------------------
19989 -- Locking_Policy --
19990 --------------------
19992 -- pragma Locking_Policy (policy_IDENTIFIER);
19994 when Pragma_Locking_Policy
=> declare
19995 subtype LP_Range
is Name_Id
19996 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
20001 Check_Ada_83_Warning
;
20002 Check_Arg_Count
(1);
20003 Check_No_Identifiers
;
20004 Check_Arg_Is_Locking_Policy
(Arg1
);
20005 Check_Valid_Configuration_Pragma
;
20006 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20009 when Name_Ceiling_Locking
=> LP
:= 'C';
20010 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
20011 when Name_Inheritance_Locking
=> LP
:= 'I';
20014 if Locking_Policy
/= ' '
20015 and then Locking_Policy
/= LP
20017 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20018 Error_Pragma
("locking policy incompatible with policy#");
20020 -- Set new policy, but always preserve System_Location since we
20021 -- like the error message with the run time name.
20024 Locking_Policy
:= LP
;
20026 if Locking_Policy_Sloc
/= System_Location
then
20027 Locking_Policy_Sloc
:= Loc
;
20032 -------------------
20033 -- Loop_Optimize --
20034 -------------------
20036 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
20038 -- OPTIMIZATION_HINT ::=
20039 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
20041 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
20046 Check_At_Least_N_Arguments
(1);
20047 Check_No_Identifiers
;
20049 Hint
:= First
(Pragma_Argument_Associations
(N
));
20050 while Present
(Hint
) loop
20051 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
20059 Check_Loop_Pragma_Placement
;
20066 -- pragma Loop_Variant
20067 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
20069 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
20071 -- CHANGE_DIRECTION ::= Increases | Decreases
20073 when Pragma_Loop_Variant
=> Loop_Variant
: declare
20078 Check_At_Least_N_Arguments
(1);
20079 Check_Loop_Pragma_Placement
;
20081 -- Process all increasing / decreasing expressions
20083 Variant
:= First
(Pragma_Argument_Associations
(N
));
20084 while Present
(Variant
) loop
20085 if Chars
(Variant
) = No_Name
then
20086 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
20088 elsif Chars
(Variant
) not in
20089 Name_Decreases | Name_Increases | Name_Structural
20092 Name
: String := Get_Name_String
(Chars
(Variant
));
20095 -- It is a common mistake to write "Increasing" for
20096 -- "Increases" or "Decreasing" for "Decreases". Recognize
20097 -- specially names starting with "incr" or "decr" to
20098 -- suggest the corresponding name.
20100 System
.Case_Util
.To_Lower
(Name
);
20102 if Name
'Length >= 4
20103 and then Name
(1 .. 4) = "incr"
20105 Error_Pragma_Arg_Ident
20106 ("expect name `Increases`", Variant
);
20108 elsif Name
'Length >= 4
20109 and then Name
(1 .. 4) = "decr"
20111 Error_Pragma_Arg_Ident
20112 ("expect name `Decreases`", Variant
);
20114 elsif Name
'Length >= 4
20115 and then Name
(1 .. 4) = "stru"
20117 Error_Pragma_Arg_Ident
20118 ("expect name `Structural`", Variant
);
20121 Error_Pragma_Arg_Ident
20122 ("expect name `Increases`, `Decreases`,"
20123 & " or `Structural`", Variant
);
20127 elsif Chars
(Variant
) = Name_Structural
20128 and then List_Length
(Pragma_Argument_Associations
(N
)) > 1
20130 Error_Pragma_Arg_Ident
20131 ("Structural variant shall be the only variant", Variant
);
20134 -- Preanalyze_Assert_Expression, but without enforcing any of
20135 -- the two acceptable types.
20137 Preanalyze_Assert_Expression
(Expression
(Variant
));
20139 -- Expression of a discrete type is allowed. Nothing to
20140 -- check for structural variants.
20142 if Chars
(Variant
) = Name_Structural
20143 or else Is_Discrete_Type
(Etype
(Expression
(Variant
)))
20147 -- Expression of a Big_Integer type (or its ghost variant) is
20148 -- only allowed in Decreases clause.
20151 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
20154 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
20157 if Chars
(Variant
) = Name_Increases
then
20159 ("Loop_Variant with Big_Integer can only decrease",
20160 Expression
(Variant
));
20163 -- Expression of other types is not allowed
20167 ("expected a discrete or Big_Integer type",
20168 Expression
(Variant
));
20175 -----------------------
20176 -- Machine_Attribute --
20177 -----------------------
20179 -- pragma Machine_Attribute (
20180 -- [Entity =>] LOCAL_NAME,
20181 -- [Attribute_Name =>] static_string_EXPRESSION
20182 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
20184 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
20186 Def_Id
: Entity_Id
;
20190 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
20192 if Arg_Count
>= 3 then
20193 Check_Optional_Identifier
(Arg3
, Name_Info
);
20195 while Present
(Arg
) loop
20196 Check_Arg_Is_OK_Static_Expression
(Arg
);
20200 Check_Arg_Count
(2);
20203 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20204 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
20205 Check_Arg_Is_Local_Name
(Arg1
);
20206 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
20207 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20209 -- Apply the pragma to the designated type, rather than to the
20210 -- access type, unless it's a strub annotation. We wish to enable
20211 -- objects of access type, as well as access types themselves, to
20212 -- be annotated, so that reading the access objects (as oposed to
20213 -- the designated data) automatically enables stack
20214 -- scrubbing. That said, as in the attribute handler that
20215 -- processes the pragma turned into a compiler attribute, a strub
20216 -- annotation that must be associated with a subprogram type (for
20217 -- holding an explicit strub mode), when applied to an
20218 -- access-to-subprogram, gets promoted to the subprogram type. We
20219 -- might be tempted to leave it alone here, since the C attribute
20220 -- handler will adjust it, but then GNAT would convert the
20221 -- annotated subprogram types to naked ones before using them,
20222 -- cancelling out their intended effects.
20224 if Is_Access_Type
(Def_Id
)
20225 and then (not Strub_Pragma_P
(N
)
20229 Ekind
(Designated_Type
20230 (Def_Id
)) = E_Subprogram_Type
))
20232 Def_Id
:= Designated_Type
(Def_Id
);
20235 if Rep_Item_Too_Early
(Def_Id
, N
) then
20239 Def_Id
:= Underlying_Type
(Def_Id
);
20241 -- The only processing required is to link this item on to the
20242 -- list of rep items for the given entity. This is accomplished
20243 -- by the call to Rep_Item_Too_Late (when no error is detected
20244 -- and False is returned).
20246 if Rep_Item_Too_Late
(Def_Id
, N
) then
20249 Set_Has_Gigi_Rep_Item
(Def_Id
);
20251 end Machine_Attribute
;
20258 -- (MAIN_OPTION [, MAIN_OPTION]);
20261 -- [STACK_SIZE =>] static_integer_EXPRESSION
20262 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
20263 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
20265 when Pragma_Main
=> Main
: declare
20266 Args
: Args_List
(1 .. 3);
20267 Names
: constant Name_List
(1 .. 3) := (
20269 Name_Task_Stack_Size_Default
,
20270 Name_Time_Slicing_Enabled
);
20276 Gather_Associations
(Names
, Args
);
20278 for J
in 1 .. 2 loop
20279 if Present
(Args
(J
)) then
20280 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
20284 if Present
(Args
(3)) then
20285 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
20289 while Present
(Nod
) loop
20290 if Nkind
(Nod
) = N_Pragma
20291 and then Pragma_Name
(Nod
) = Name_Main
20293 Error_Msg_Name_1
:= Pname
;
20294 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20305 -- pragma Main_Storage
20306 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
20308 -- MAIN_STORAGE_OPTION ::=
20309 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
20310 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
20312 when Pragma_Main_Storage
=> Main_Storage
: declare
20313 Args
: Args_List
(1 .. 2);
20314 Names
: constant Name_List
(1 .. 2) := (
20315 Name_Working_Storage
,
20322 Gather_Associations
(Names
, Args
);
20324 for J
in 1 .. 2 loop
20325 if Present
(Args
(J
)) then
20326 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
20330 Check_In_Main_Program
;
20333 while Present
(Nod
) loop
20334 if Nkind
(Nod
) = N_Pragma
20335 and then Pragma_Name
(Nod
) = Name_Main_Storage
20337 Error_Msg_Name_1
:= Pname
;
20338 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20345 ----------------------------
20346 -- Max_Entry_Queue_Length --
20347 ----------------------------
20349 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
20351 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
20352 -- Pragma_Max_Queue_Length.
20354 when Pragma_Max_Entry_Queue_Length
20355 | Pragma_Max_Entry_Queue_Depth
20356 | Pragma_Max_Queue_Length
20358 Max_Entry_Queue_Length
: declare
20360 Entry_Decl
: Node_Id
;
20361 Entry_Id
: Entity_Id
;
20365 if Prag_Id
= Pragma_Max_Entry_Queue_Depth
20366 or else Prag_Id
= Pragma_Max_Queue_Length
20371 Check_Arg_Count
(1);
20374 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
20376 -- Entry declaration
20378 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
20380 -- Entry illegally within a task
20382 if Nkind
(Parent
(N
)) = N_Task_Definition
then
20383 Error_Pragma
("pragma % cannot apply to task entries");
20386 Entry_Id
:= Defining_Entity
(Entry_Decl
);
20388 -- Otherwise the pragma is associated with an illegal construct
20392 ("pragma % must apply to a protected entry declaration");
20395 -- Mark the pragma as Ghost if the related subprogram is also
20396 -- Ghost. This also ensures that any expansion performed further
20397 -- below will produce Ghost nodes.
20399 Mark_Ghost_Pragma
(N
, Entry_Id
);
20401 -- Analyze the Integer expression
20403 Arg
:= Get_Pragma_Arg
(Arg1
);
20404 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
20406 Val
:= Expr_Value
(Arg
);
20410 ("argument for pragma% cannot be less than -1", Arg1
);
20412 elsif not UI_Is_In_Int_Range
(Val
) then
20414 ("argument for pragma% out of range of Integer", Arg1
);
20418 Record_Rep_Item
(Entry_Id
, N
);
20419 end Max_Entry_Queue_Length
;
20425 -- pragma Memory_Size (NUMERIC_LITERAL)
20427 when Pragma_Memory_Size
=>
20430 -- Memory size is simply ignored
20432 Check_No_Identifiers
;
20433 Check_Arg_Count
(1);
20434 Check_Arg_Is_Integer_Literal
(Arg1
);
20442 -- The only correct use of this pragma is on its own in a file, in
20443 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
20444 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
20445 -- check for a file containing nothing but a No_Body pragma). If we
20446 -- attempt to process it during normal semantics processing, it means
20447 -- it was misplaced.
20449 when Pragma_No_Body
=>
20453 -----------------------------
20454 -- No_Elaboration_Code_All --
20455 -----------------------------
20457 -- pragma No_Elaboration_Code_All;
20459 when Pragma_No_Elaboration_Code_All
=>
20461 Check_Valid_Library_Unit_Pragma
;
20463 -- If N was rewritten as a null statement there is nothing more
20466 if Nkind
(N
) = N_Null_Statement
then
20470 -- Must appear for a spec or generic spec
20472 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) not in
20473 N_Generic_Package_Declaration |
20474 N_Generic_Subprogram_Declaration |
20475 N_Package_Declaration |
20476 N_Subprogram_Declaration
20480 ("pragma% can only occur for package "
20481 & "or subprogram spec"));
20484 -- Set flag in unit table
20486 Set_No_Elab_Code_All
(Current_Sem_Unit
);
20488 -- Set restriction No_Elaboration_Code if this is the main unit
20490 if Current_Sem_Unit
= Main_Unit
then
20491 Set_Restriction
(No_Elaboration_Code
, N
);
20494 -- If we are in the main unit or in an extended main source unit,
20495 -- then we also add it to the configuration restrictions so that
20496 -- it will apply to all units in the extended main source.
20498 if Current_Sem_Unit
= Main_Unit
20499 or else In_Extended_Main_Source_Unit
(N
)
20501 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
20504 -- If in main extended unit, activate transitive with test
20506 if In_Extended_Main_Source_Unit
(N
) then
20507 Opt
.No_Elab_Code_All_Pragma
:= N
;
20510 -----------------------------
20511 -- No_Component_Reordering --
20512 -----------------------------
20514 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
20516 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
20522 Check_At_Most_N_Arguments
(1);
20524 if Arg_Count
= 0 then
20525 Check_Valid_Configuration_Pragma
;
20526 Opt
.No_Component_Reordering
:= True;
20529 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20530 Check_Arg_Is_Local_Name
(Arg1
);
20531 E_Id
:= Get_Pragma_Arg
(Arg1
);
20533 if Etype
(E_Id
) = Any_Type
then
20537 E
:= Entity
(E_Id
);
20539 if not Is_Record_Type
(E
) then
20540 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
20543 Set_No_Reordering
(Base_Type
(E
));
20545 end No_Comp_Reordering
;
20547 --------------------------
20548 -- No_Heap_Finalization --
20549 --------------------------
20551 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
20553 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
20554 Context
: constant Node_Id
:= Parent
(N
);
20555 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20561 Check_No_Identifiers
;
20563 -- The pragma appears in a configuration file
20565 if No
(Context
) then
20566 Check_Arg_Count
(0);
20567 Check_Valid_Configuration_Pragma
;
20569 -- Detect a duplicate pragma
20571 if Present
(No_Heap_Finalization_Pragma
) then
20574 Prev
=> No_Heap_Finalization_Pragma
);
20578 No_Heap_Finalization_Pragma
:= N
;
20580 -- Otherwise the pragma should be associated with a library-level
20581 -- named access-to-object type.
20584 Check_Arg_Count
(1);
20585 Check_Arg_Is_Local_Name
(Arg1
);
20587 Find_Type
(Typ_Arg
);
20588 Typ
:= Entity
(Typ_Arg
);
20590 -- The type being subjected to the pragma is erroneous
20592 if Typ
= Any_Type
then
20593 Error_Pragma
("cannot find type referenced by pragma %");
20595 -- The pragma is applied to an incomplete or generic formal
20596 -- type way too early.
20598 elsif Rep_Item_Too_Early
(Typ
, N
) then
20602 Typ
:= Underlying_Type
(Typ
);
20605 -- The pragma must apply to an access-to-object type
20607 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
then
20610 -- Give a detailed error message on all other access type kinds
20612 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
20614 ("pragma % cannot apply to access protected subprogram "
20617 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
20619 ("pragma % cannot apply to access subprogram type");
20621 elsif Is_Anonymous_Access_Type
(Typ
) then
20623 ("pragma % cannot apply to anonymous access type");
20625 -- Give a general error message in case the pragma applies to a
20626 -- non-access type.
20630 ("pragma % must apply to library level access type");
20633 -- At this point the argument denotes an access-to-object type.
20634 -- Ensure that the type is declared at the library level.
20636 if Is_Library_Level_Entity
(Typ
) then
20639 -- Quietly ignore an access-to-object type originally declared
20640 -- at the library level within a generic, but instantiated at
20641 -- a non-library level. As a result the access-to-object type
20642 -- "loses" its No_Heap_Finalization property.
20644 elsif In_Instance
then
20649 ("pragma % must apply to library level access type");
20652 -- Detect a duplicate pragma
20654 if Present
(No_Heap_Finalization_Pragma
) then
20657 Prev
=> No_Heap_Finalization_Pragma
);
20661 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
20663 if Present
(Prev
) then
20671 Record_Rep_Item
(Typ
, N
);
20673 end No_Heap_Finalization
;
20679 -- pragma No_Inline ( NAME {, NAME} );
20681 when Pragma_No_Inline
=>
20683 Process_Inline
(Suppressed
);
20689 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20691 when Pragma_No_Return
=> Prag_No_Return
: declare
20693 function Check_No_Return
20695 N
: Node_Id
) return Boolean;
20696 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
20697 -- emit an error message and return False, otherwise return True.
20698 -- 6.5.1 Nonreturning procedures:
20699 -- 4/3 "Aspect No_Return shall not be specified for a null
20700 -- procedure nor an instance of a generic unit."
20702 ---------------------
20703 -- Check_No_Return --
20704 ---------------------
20706 function Check_No_Return
20708 N
: Node_Id
) return Boolean
20711 if Ekind
(E
) in E_Function | E_Generic_Function
then
20712 Error_Msg_Ada_2022_Feature
("No_Return function", Sloc
(N
));
20713 return Ada_Version
>= Ada_2022
;
20715 elsif Ekind
(E
) = E_Procedure
then
20717 -- If E is a generic instance, marking it with No_Return
20718 -- is forbidden, but having it inherit the No_Return of
20719 -- the generic is allowed. We check if E is inheriting its
20720 -- No_Return flag from the generic by checking if No_Return
20723 if Is_Generic_Instance
(E
) and then not No_Return
(E
) then
20725 ("generic instance & is marked as No_Return", N
, E
);
20727 ("\generic procedure & must be marked No_Return",
20729 Generic_Parent
(Parent
(E
)));
20732 elsif Null_Present
(Subprogram_Specification
(E
)) then
20734 ("null procedure & cannot be marked No_Return", N
, E
);
20740 end Check_No_Return
;
20747 Ghost_Error_Posted
: Boolean := False;
20748 -- Flag set when an error concerning the illegal mix of Ghost and
20749 -- non-Ghost subprograms is emitted.
20751 Ghost_Id
: Entity_Id
:= Empty
;
20752 -- The entity of the first Ghost procedure encountered while
20753 -- processing the arguments of the pragma.
20757 Check_At_Least_N_Arguments
(1);
20759 -- Loop through arguments of pragma
20762 while Present
(Arg
) loop
20763 Check_Arg_Is_Local_Name
(Arg
);
20764 Id
:= Get_Pragma_Arg
(Arg
);
20767 if not Is_Entity_Name
(Id
) then
20768 Error_Pragma_Arg
("entity name required", Arg
);
20771 if Etype
(Id
) = Any_Type
then
20775 -- Loop to find matching procedures or functions (Ada 2022)
20781 and then Scope
(E
) = Current_Scope
20783 -- Ada 2022 (AI12-0269): A function can be No_Return
20785 if Ekind
(E
) in E_Generic_Procedure | E_Procedure
20786 | E_Generic_Function | E_Function
20788 -- Check that the pragma is not applied to a body.
20789 -- First check the specless body case, to give a
20790 -- different error message. These checks do not apply
20791 -- if Relaxed_RM_Semantics, to accommodate other Ada
20792 -- compilers. Disable these checks under -gnatd.J.
20794 if not Debug_Flag_Dot_JJ
then
20795 if Nkind
(Parent
(Declaration_Node
(E
))) =
20797 and then not Relaxed_RM_Semantics
20800 ("pragma% requires separate spec and must come "
20804 -- Now the "specful" body case
20806 if Rep_Item_Too_Late
(E
, N
) then
20811 if Check_No_Return
(E
, N
) then
20815 -- A pragma that applies to a Ghost entity becomes Ghost
20816 -- for the purposes of legality checks and removal of
20817 -- ignored Ghost code.
20819 Mark_Ghost_Pragma
(N
, E
);
20821 -- Capture the entity of the first Ghost procedure being
20822 -- processed for error detection purposes.
20824 if Is_Ghost_Entity
(E
) then
20825 if No
(Ghost_Id
) then
20829 -- Otherwise the subprogram is non-Ghost. It is illegal
20830 -- to mix references to Ghost and non-Ghost entities
20833 elsif Present
(Ghost_Id
)
20834 and then not Ghost_Error_Posted
20836 Ghost_Error_Posted
:= True;
20838 Error_Msg_Name_1
:= Pname
;
20840 ("pragma % cannot mention ghost and non-ghost "
20841 & "procedures", N
);
20843 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
20844 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
20846 Error_Msg_Sloc
:= Sloc
(E
);
20847 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
20850 -- Set flag on any alias as well
20852 if Is_Overloadable
(E
)
20853 and then Present
(Alias
(E
))
20854 and then Check_No_Return
(Alias
(E
), N
)
20856 Set_No_Return
(Alias
(E
));
20862 exit when From_Aspect_Specification
(N
);
20866 -- If entity in not in current scope it may be the enclosing
20867 -- subprogram body to which the aspect applies.
20870 if Entity
(Id
) = Current_Scope
20871 and then From_Aspect_Specification
(N
)
20872 and then Check_No_Return
(Entity
(Id
), N
)
20874 Set_No_Return
(Entity
(Id
));
20876 elsif Ada_Version
>= Ada_2022
then
20878 ("no subprogram& found for pragma%", Arg
);
20881 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
20887 end Prag_No_Return
;
20893 -- pragma No_Run_Time;
20895 -- Note: this pragma is retained for backwards compatibility. See
20896 -- body of Rtsfind for full details on its handling.
20898 when Pragma_No_Run_Time
=>
20900 Check_Valid_Configuration_Pragma
;
20901 Check_Arg_Count
(0);
20903 -- Remove backward compatibility if Build_Type is FSF or GPL and
20904 -- generate a warning.
20907 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
20910 Error_Pragma
("pragma% is ignored, has no effect??");
20912 No_Run_Time_Mode
:= True;
20913 Configurable_Run_Time_Mode
:= True;
20915 -- Set Duration to 32 bits if word size is 32
20917 if Ttypes
.System_Word_Size
= 32 then
20918 Duration_32_Bits_On_Target
:= True;
20921 -- Set appropriate restrictions
20923 Set_Restriction
(No_Finalization
, N
);
20924 Set_Restriction
(No_Exception_Handlers
, N
);
20925 Set_Restriction
(Max_Tasks
, N
, 0);
20926 Set_Restriction
(No_Tasking
, N
);
20930 -----------------------
20931 -- No_Tagged_Streams --
20932 -----------------------
20934 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20936 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20942 Check_At_Most_N_Arguments
(1);
20944 -- One argument case
20946 if Arg_Count
= 1 then
20947 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20948 Check_Arg_Is_Local_Name
(Arg1
);
20949 E_Id
:= Get_Pragma_Arg
(Arg1
);
20951 if Etype
(E_Id
) = Any_Type
then
20955 E
:= Entity
(E_Id
);
20957 Check_Duplicate_Pragma
(E
);
20959 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20961 ("argument for pragma% must be root tagged type", Arg1
);
20964 if Rep_Item_Too_Early
(E
, N
)
20966 Rep_Item_Too_Late
(E
, N
)
20970 Set_No_Tagged_Streams_Pragma
(E
, N
);
20973 -- Zero argument case
20976 Check_Is_In_Decl_Part_Or_Package_Spec
;
20977 No_Tagged_Streams
:= N
;
20979 end No_Tagged_Strms
;
20981 ------------------------
20982 -- No_Strict_Aliasing --
20983 ------------------------
20985 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20987 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20993 Check_At_Most_N_Arguments
(1);
20995 if Arg_Count
= 0 then
20996 Check_Valid_Configuration_Pragma
;
20997 Opt
.No_Strict_Aliasing
:= True;
21000 Check_Optional_Identifier
(Arg2
, Name_Entity
);
21001 Check_Arg_Is_Local_Name
(Arg1
);
21002 E_Id
:= Get_Pragma_Arg
(Arg1
);
21004 if Etype
(E_Id
) = Any_Type
then
21008 E
:= Entity
(E_Id
);
21010 if not Is_Access_Type
(E
) then
21011 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
21014 Set_No_Strict_Aliasing
(Base_Type
(E
));
21016 end No_Strict_Aliasing
;
21018 -----------------------
21019 -- Normalize_Scalars --
21020 -----------------------
21022 -- pragma Normalize_Scalars;
21024 when Pragma_Normalize_Scalars
=>
21025 Check_Ada_83_Warning
;
21026 Check_Arg_Count
(0);
21027 Check_Valid_Configuration_Pragma
;
21029 -- Normalize_Scalars creates false positives in CodePeer, and
21030 -- incorrect negative results in GNATprove mode, so ignore this
21031 -- pragma in these modes.
21033 if not (CodePeer_Mode
or GNATprove_Mode
) then
21034 Normalize_Scalars
:= True;
21035 Init_Or_Norm_Scalars
:= True;
21042 -- pragma Obsolescent;
21044 -- pragma Obsolescent (
21045 -- [Message =>] static_string_EXPRESSION
21046 -- [,[Version =>] Ada_05]);
21048 -- pragma Obsolescent (
21049 -- [Entity =>] NAME
21050 -- [,[Message =>] static_string_EXPRESSION
21051 -- [,[Version =>] Ada_05]]);
21053 when Pragma_Obsolescent
=> Obsolescent
: declare
21057 procedure Set_Obsolescent
(E
: Entity_Id
);
21058 -- Given an entity Ent, mark it as obsolescent if appropriate
21060 ---------------------
21061 -- Set_Obsolescent --
21062 ---------------------
21064 procedure Set_Obsolescent
(E
: Entity_Id
) is
21073 -- A pragma that applies to a Ghost entity becomes Ghost for
21074 -- the purposes of legality checks and removal of ignored Ghost
21077 Mark_Ghost_Pragma
(N
, E
);
21079 -- Entity name was given
21081 if Present
(Ename
) then
21083 -- If entity name matches, we are fine.
21085 if Chars
(Ename
) = Chars
(Ent
) then
21086 Set_Entity
(Ename
, Ent
);
21087 Generate_Reference
(Ent
, Ename
);
21089 -- If entity name does not match, only possibility is an
21090 -- enumeration literal from an enumeration type declaration.
21092 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
21094 ("pragma % entity name does not match declaration");
21097 Ent
:= First_Literal
(E
);
21101 ("pragma % entity name does not match any "
21102 & "enumeration literal");
21104 elsif Chars
(Ent
) = Chars
(Ename
) then
21105 Set_Entity
(Ename
, Ent
);
21106 Generate_Reference
(Ent
, Ename
);
21110 Next_Literal
(Ent
);
21116 -- Ent points to entity to be marked
21118 if Arg_Count
>= 1 then
21120 -- Deal with static string argument
21122 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21123 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
21125 for J
in 1 .. String_Length
(S
) loop
21126 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
21128 ("pragma% argument does not allow wide characters",
21133 Obsolescent_Warnings
.Append
21134 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
21136 -- Check for Ada_05 parameter
21138 if Arg_Count
/= 1 then
21139 Check_Arg_Count
(2);
21142 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21145 Check_Arg_Is_Identifier
(Argx
);
21147 if Chars
(Argx
) /= Name_Ada_05
then
21148 Error_Msg_Name_2
:= Name_Ada_05
;
21150 ("only allowed argument for pragma% is %", Argx
);
21153 if Ada_Version_Explicit
< Ada_2005
21154 or else not Warn_On_Ada_2005_Compatibility
21162 -- Set flag if pragma active
21165 Set_Is_Obsolescent
(Ent
);
21169 end Set_Obsolescent
;
21171 -- Start of processing for pragma Obsolescent
21176 Check_At_Most_N_Arguments
(3);
21178 -- See if first argument specifies an entity name
21182 (Chars
(Arg1
) = Name_Entity
21184 Nkind
(Get_Pragma_Arg
(Arg1
)) in
21185 N_Character_Literal | N_Identifier | N_Operator_Symbol
)
21187 Ename
:= Get_Pragma_Arg
(Arg1
);
21189 -- Eliminate first argument, so we can share processing
21193 Arg_Count
:= Arg_Count
- 1;
21195 -- No Entity name argument given
21201 if Arg_Count
>= 1 then
21202 Check_Optional_Identifier
(Arg1
, Name_Message
);
21204 if Arg_Count
= 2 then
21205 Check_Optional_Identifier
(Arg2
, Name_Version
);
21209 -- Get immediately preceding declaration
21212 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
21216 -- Cases where we do not follow anything other than another pragma
21220 -- Case 0: library level compilation unit declaration with
21221 -- the pragma preceding the declaration.
21223 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
21226 -- Case 1: library level compilation unit declaration with
21227 -- the pragma immediately following the declaration.
21229 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
21231 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
21234 -- Case 2: library unit placement for package
21238 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
21240 if Is_Package_Or_Generic_Package
(Ent
) then
21241 Set_Obsolescent
(Ent
);
21247 -- Cases where we must follow a declaration, including an
21248 -- abstract subprogram declaration, which is not in the
21249 -- other node subtypes.
21252 if Nkind
(Decl
) not in N_Declaration
21253 and then Nkind
(Decl
) not in N_Later_Decl_Item
21254 and then Nkind
(Decl
) not in N_Generic_Declaration
21255 and then Nkind
(Decl
) not in N_Renaming_Declaration
21256 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
21259 ("pragma% misplaced, "
21260 & "must immediately follow a declaration");
21263 Set_Obsolescent
(Defining_Entity
(Decl
));
21273 -- pragma Optimize (Time | Space | Off);
21275 -- The actual check for optimize is done in Gigi. Note that this
21276 -- pragma does not actually change the optimization setting, it
21277 -- simply checks that it is consistent with the pragma.
21279 when Pragma_Optimize
=>
21280 Check_No_Identifiers
;
21281 Check_Arg_Count
(1);
21282 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
21284 ------------------------
21285 -- Optimize_Alignment --
21286 ------------------------
21288 -- pragma Optimize_Alignment (Time | Space | Off);
21290 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
21292 Check_No_Identifiers
;
21293 Check_Arg_Count
(1);
21294 Check_Valid_Configuration_Pragma
;
21297 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
21300 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
21301 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
21302 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
21305 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
21309 -- Set indication that mode is set locally. If we are in fact in a
21310 -- configuration pragma file, this setting is harmless since the
21311 -- switch will get reset anyway at the start of each unit.
21313 Optimize_Alignment_Local
:= True;
21314 end Optimize_Alignment
;
21320 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
21322 when Pragma_Ordered
=> Ordered
: declare
21323 Assoc
: constant Node_Id
:= Arg1
;
21329 Check_No_Identifiers
;
21330 Check_Arg_Count
(1);
21331 Check_Arg_Is_Local_Name
(Arg1
);
21333 Type_Id
:= Get_Pragma_Arg
(Assoc
);
21334 Find_Type
(Type_Id
);
21335 Typ
:= Entity
(Type_Id
);
21337 if Typ
= Any_Type
then
21340 Typ
:= Underlying_Type
(Typ
);
21343 if not Is_Enumeration_Type
(Typ
) then
21344 Error_Pragma
("pragma% must specify enumeration type");
21347 Check_First_Subtype
(Arg1
);
21348 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
21351 -------------------
21352 -- Overflow_Mode --
21353 -------------------
21355 -- pragma Overflow_Mode
21356 -- ([General => ] MODE [, [Assertions => ] MODE]);
21358 -- MODE := STRICT | MINIMIZED | ELIMINATED
21360 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
21361 -- since System.Bignums makes this assumption. This is true of nearly
21362 -- all (all?) targets.
21364 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
21365 function Get_Overflow_Mode
21367 Arg
: Node_Id
) return Overflow_Mode_Type
;
21368 -- Function to process one pragma argument, Arg. If an identifier
21369 -- is present, it must be Name. Mode type is returned if a valid
21370 -- argument exists, otherwise an error is signalled.
21372 -----------------------
21373 -- Get_Overflow_Mode --
21374 -----------------------
21376 function Get_Overflow_Mode
21378 Arg
: Node_Id
) return Overflow_Mode_Type
21380 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
21383 Check_Optional_Identifier
(Arg
, Name
);
21384 Check_Arg_Is_Identifier
(Argx
);
21386 if Chars
(Argx
) = Name_Strict
then
21389 elsif Chars
(Argx
) = Name_Minimized
then
21392 elsif Chars
(Argx
) = Name_Eliminated
then
21393 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
21395 ("Eliminated requires Long_Long_Integer'Size = 64",
21402 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
21404 end Get_Overflow_Mode
;
21406 -- Start of processing for Overflow_Mode
21410 Check_At_Least_N_Arguments
(1);
21411 Check_At_Most_N_Arguments
(2);
21413 -- Process first argument
21415 Scope_Suppress
.Overflow_Mode_General
:=
21416 Get_Overflow_Mode
(Name_General
, Arg1
);
21418 -- Case of only one argument
21420 if Arg_Count
= 1 then
21421 Scope_Suppress
.Overflow_Mode_Assertions
:=
21422 Scope_Suppress
.Overflow_Mode_General
;
21424 -- Case of two arguments present
21427 Scope_Suppress
.Overflow_Mode_Assertions
:=
21428 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
21432 --------------------------
21433 -- Overriding Renamings --
21434 --------------------------
21436 -- pragma Overriding_Renamings;
21438 when Pragma_Overriding_Renamings
=>
21440 Check_Arg_Count
(0);
21441 Check_Valid_Configuration_Pragma
;
21442 Overriding_Renamings
:= True;
21448 -- pragma Pack (first_subtype_LOCAL_NAME);
21450 when Pragma_Pack
=> Pack
: declare
21451 Assoc
: constant Node_Id
:= Arg1
;
21453 Ignore
: Boolean := False;
21458 Check_No_Identifiers
;
21459 Check_Arg_Count
(1);
21460 Check_Arg_Is_Local_Name
(Arg1
);
21461 Type_Id
:= Get_Pragma_Arg
(Assoc
);
21463 if not Is_Entity_Name
(Type_Id
)
21464 or else not Is_Type
(Entity
(Type_Id
))
21467 ("argument for pragma% must be type or subtype", Arg1
);
21470 Find_Type
(Type_Id
);
21471 Typ
:= Entity
(Type_Id
);
21474 or else Rep_Item_Too_Early
(Typ
, N
)
21478 Typ
:= Underlying_Type
(Typ
);
21481 -- A pragma that applies to a Ghost entity becomes Ghost for the
21482 -- purposes of legality checks and removal of ignored Ghost code.
21484 Mark_Ghost_Pragma
(N
, Typ
);
21486 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
21487 Error_Pragma
("pragma% must specify array or record type");
21490 Check_First_Subtype
(Arg1
);
21491 Check_Duplicate_Pragma
(Typ
);
21495 if Is_Array_Type
(Typ
) then
21496 Ctyp
:= Component_Type
(Typ
);
21498 -- Ignore pack that does nothing
21500 if Known_Static_Esize
(Ctyp
)
21501 and then Known_Static_RM_Size
(Ctyp
)
21502 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
21503 and then Addressable
(Esize
(Ctyp
))
21508 -- Process OK pragma Pack. Note that if there is a separate
21509 -- component clause present, the Pack will be cancelled. This
21510 -- processing is in Freeze.
21512 if not Rep_Item_Too_Late
(Typ
, N
) then
21514 -- In CodePeer mode, we do not need complex front-end
21515 -- expansions related to pragma Pack, so disable handling
21518 if CodePeer_Mode
then
21521 -- Normal case where we do the pack action
21525 Set_Is_Packed
(Base_Type
(Typ
));
21526 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
21529 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
21533 -- For record types, the pack is always effective
21535 else pragma Assert
(Is_Record_Type
(Typ
));
21536 if not Rep_Item_Too_Late
(Typ
, N
) then
21537 Set_Is_Packed
(Base_Type
(Typ
));
21538 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
21539 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
21550 -- There is nothing to do here, since we did all the processing for
21551 -- this pragma in Par.Prag (so that it works properly even in syntax
21554 when Pragma_Page
=>
21561 -- pragma Part_Of (ABSTRACT_STATE);
21563 -- ABSTRACT_STATE ::= NAME
21565 when Pragma_Part_Of
=> Part_Of
: declare
21566 procedure Propagate_Part_Of
21567 (Pack_Id
: Entity_Id
;
21568 State_Id
: Entity_Id
;
21569 Instance
: Node_Id
);
21570 -- Propagate the Part_Of indicator to all abstract states and
21571 -- objects declared in the visible state space of a package
21572 -- denoted by Pack_Id. State_Id is the encapsulating state.
21573 -- Instance is the package instantiation node.
21575 -----------------------
21576 -- Propagate_Part_Of --
21577 -----------------------
21579 procedure Propagate_Part_Of
21580 (Pack_Id
: Entity_Id
;
21581 State_Id
: Entity_Id
;
21582 Instance
: Node_Id
)
21584 Has_Item
: Boolean := False;
21585 -- Flag set when the visible state space contains at least one
21586 -- abstract state or variable.
21588 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
21589 -- Propagate the Part_Of indicator to all abstract states and
21590 -- objects declared in the visible state space of a package
21591 -- denoted by Pack_Id.
21593 -----------------------
21594 -- Propagate_Part_Of --
21595 -----------------------
21597 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
21598 Constits
: Elist_Id
;
21599 Item_Id
: Entity_Id
;
21602 -- Traverse the entity chain of the package and set relevant
21603 -- attributes of abstract states and objects declared in the
21604 -- visible state space of the package.
21606 Item_Id
:= First_Entity
(Pack_Id
);
21607 while Present
(Item_Id
)
21608 and then not In_Private_Part
(Item_Id
)
21610 -- Do not consider internally generated items
21612 if not Comes_From_Source
(Item_Id
) then
21615 -- Do not consider generic formals or their corresponding
21616 -- actuals because they are not part of a visible state.
21617 -- Note that both entities are marked as hidden.
21619 elsif Is_Hidden
(Item_Id
) then
21622 -- The Part_Of indicator turns an abstract state or an
21623 -- object into a constituent of the encapsulating state.
21624 -- Note that constants are considered here even though
21625 -- they may not depend on variable input. This check is
21626 -- left to the SPARK prover.
21628 elsif Ekind
(Item_Id
) in
21629 E_Abstract_State | E_Constant | E_Variable
21632 Constits
:= Part_Of_Constituents
(State_Id
);
21634 if No
(Constits
) then
21635 Constits
:= New_Elmt_List
;
21636 Set_Part_Of_Constituents
(State_Id
, Constits
);
21639 Append_Elmt
(Item_Id
, Constits
);
21640 Set_Encapsulating_State
(Item_Id
, State_Id
);
21642 -- Recursively handle nested packages and instantiations
21644 elsif Ekind
(Item_Id
) = E_Package
then
21645 Propagate_Part_Of
(Item_Id
);
21648 Next_Entity
(Item_Id
);
21650 end Propagate_Part_Of
;
21652 -- Start of processing for Propagate_Part_Of
21655 Propagate_Part_Of
(Pack_Id
);
21657 -- Detect a package instantiation that is subject to a Part_Of
21658 -- indicator, but has no visible state.
21660 if not Has_Item
then
21662 ("package instantiation & has Part_Of indicator but "
21663 & "lacks visible state", Instance
, Pack_Id
);
21665 end Propagate_Part_Of
;
21669 Constits
: Elist_Id
;
21671 Encap_Id
: Entity_Id
;
21672 Item_Id
: Entity_Id
;
21676 -- Start of processing for Part_Of
21680 Check_No_Identifiers
;
21681 Check_Arg_Count
(1);
21683 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
21685 -- Object declaration
21687 if Nkind
(Stmt
) = N_Object_Declaration
then
21690 -- Package instantiation
21692 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
21695 -- Single concurrent type declaration
21697 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
21700 -- Otherwise the pragma is associated with an illegal construct
21706 -- Extract the entity of the related object declaration or package
21707 -- instantiation. In the case of the instantiation, use the entity
21708 -- of the instance spec.
21710 if Nkind
(Stmt
) = N_Package_Instantiation
then
21711 Stmt
:= Instance_Spec
(Stmt
);
21714 Item_Id
:= Defining_Entity
(Stmt
);
21716 -- A pragma that applies to a Ghost entity becomes Ghost for the
21717 -- purposes of legality checks and removal of ignored Ghost code.
21719 Mark_Ghost_Pragma
(N
, Item_Id
);
21721 -- Chain the pragma on the contract for further processing by
21722 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21724 Add_Contract_Item
(N
, Item_Id
);
21726 -- A variable may act as constituent of a single concurrent type
21727 -- which in turn could be declared after the variable. Due to this
21728 -- discrepancy, the full analysis of indicator Part_Of is delayed
21729 -- until the end of the enclosing declarative region (see routine
21730 -- Analyze_Part_Of_In_Decl_Part).
21732 if Ekind
(Item_Id
) = E_Variable
then
21735 -- Otherwise indicator Part_Of applies to a constant or a package
21739 Encap
:= Get_Pragma_Arg
(Arg1
);
21741 -- Detect any discrepancies between the placement of the
21742 -- constant or package instantiation with respect to state
21743 -- space and the encapsulating state.
21747 Item_Id
=> Item_Id
,
21749 Encap_Id
=> Encap_Id
,
21753 pragma Assert
(Present
(Encap_Id
));
21755 if Ekind
(Item_Id
) = E_Constant
then
21756 Constits
:= Part_Of_Constituents
(Encap_Id
);
21758 if No
(Constits
) then
21759 Constits
:= New_Elmt_List
;
21760 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
21763 Append_Elmt
(Item_Id
, Constits
);
21764 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
21766 -- Propagate the Part_Of indicator to the visible state
21767 -- space of the package instantiation.
21771 (Pack_Id
=> Item_Id
,
21772 State_Id
=> Encap_Id
,
21779 ----------------------------------
21780 -- Partition_Elaboration_Policy --
21781 ----------------------------------
21783 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21785 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
21786 subtype PEP_Range
is Name_Id
21787 range First_Partition_Elaboration_Policy_Name
21788 .. Last_Partition_Elaboration_Policy_Name
;
21789 PEP_Val
: PEP_Range
;
21794 Check_Arg_Count
(1);
21795 Check_No_Identifiers
;
21796 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
21797 Check_Valid_Configuration_Pragma
;
21798 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
21801 when Name_Concurrent
=> PEP
:= 'C';
21802 when Name_Sequential
=> PEP
:= 'S';
21805 if Partition_Elaboration_Policy
/= ' '
21806 and then Partition_Elaboration_Policy
/= PEP
21808 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
21810 ("partition elaboration policy incompatible with policy#");
21812 -- Set new policy, but always preserve System_Location since we
21813 -- like the error message with the run time name.
21816 Partition_Elaboration_Policy
:= PEP
;
21818 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
21819 Partition_Elaboration_Policy_Sloc
:= Loc
;
21822 if PEP_Val
= Name_Sequential
21823 and then not Restriction_Active
(No_Task_Hierarchy
)
21825 -- RM H.6(6) guarantees that No_Task_Hierarchy will be
21826 -- set eventually, so take advantage of that knowledge now.
21827 -- But we have to do this in a tricky way. If we simply
21828 -- set the No_Task_Hierarchy restriction here, then the
21829 -- assumption that the restriction will be set eventually
21830 -- becomes a self-fulfilling prophecy; the binder can
21831 -- then mistakenly conclude that the H.6(6) rule is
21832 -- satisified in cases where the post-compilation check
21833 -- should fail. So we invent a new restriction,
21834 -- No_Task_Hierarchy_Implicit, which is treated specially
21835 -- in the function Restriction_Active.
21837 Set_Restriction
(No_Task_Hierarchy_Implicit
, N
);
21838 pragma Assert
(Restriction_Active
(No_Task_Hierarchy
));
21847 -- pragma Passive [(PASSIVE_FORM)];
21849 -- PASSIVE_FORM ::= Semaphore | No
21851 when Pragma_Passive
=>
21854 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
21855 Error_Pragma
("pragma% must be within task definition");
21858 if Arg_Count
/= 0 then
21859 Check_Arg_Count
(1);
21860 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
21863 ----------------------------------
21864 -- Preelaborable_Initialization --
21865 ----------------------------------
21867 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21869 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
21874 Check_Arg_Count
(1);
21875 Check_No_Identifiers
;
21876 Check_Arg_Is_Identifier
(Arg1
);
21877 Check_Arg_Is_Local_Name
(Arg1
);
21878 Check_First_Subtype
(Arg1
);
21879 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21881 -- A pragma that applies to a Ghost entity becomes Ghost for the
21882 -- purposes of legality checks and removal of ignored Ghost code.
21884 Mark_Ghost_Pragma
(N
, Ent
);
21886 -- The pragma may come from an aspect on a private declaration,
21887 -- even if the freeze point at which this is analyzed in the
21888 -- private part after the full view.
21890 if Has_Private_Declaration
(Ent
)
21891 and then From_Aspect_Specification
(N
)
21895 -- Check appropriate type argument
21897 elsif Is_Private_Type
(Ent
)
21898 or else Is_Protected_Type
(Ent
)
21899 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
21901 -- AI05-0028: The pragma applies to all composite types. Note
21902 -- that we apply this binding interpretation to earlier versions
21903 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21904 -- choice since there are other compilers that do the same.
21906 or else Is_Composite_Type
(Ent
)
21912 ("pragma % can only be applied to private, formal derived, "
21913 & "protected, or composite type", Arg1
);
21916 -- Give an error if the pragma is applied to a protected type that
21917 -- does not qualify (due to having entries, or due to components
21918 -- that do not qualify).
21920 if Is_Protected_Type
(Ent
)
21921 and then not Has_Preelaborable_Initialization
(Ent
)
21924 ("protected type & does not have preelaborable "
21925 & "initialization", Ent
);
21927 -- Otherwise mark the type as definitely having preelaborable
21931 Set_Known_To_Have_Preelab_Init
(Ent
);
21934 if Has_Pragma_Preelab_Init
(Ent
)
21935 and then Warn_On_Redundant_Constructs
21937 Error_Pragma
("?r?duplicate pragma%!");
21939 Set_Has_Pragma_Preelab_Init
(Ent
);
21943 --------------------
21944 -- Persistent_BSS --
21945 --------------------
21947 -- pragma Persistent_BSS [(object_NAME)];
21949 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21956 Check_At_Most_N_Arguments
(1);
21958 -- Case of application to specific object (one argument)
21960 if Arg_Count
= 1 then
21961 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21963 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21965 Ekind
(Entity
(Get_Pragma_Arg
(Arg1
))) not in
21966 E_Variable | E_Constant
21968 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21971 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21973 -- A pragma that applies to a Ghost entity becomes Ghost for
21974 -- the purposes of legality checks and removal of ignored Ghost
21977 Mark_Ghost_Pragma
(N
, Ent
);
21979 -- Check for duplication before inserting in list of
21980 -- representation items.
21982 Check_Duplicate_Pragma
(Ent
);
21984 if Rep_Item_Too_Late
(Ent
, N
) then
21988 Decl
:= Parent
(Ent
);
21990 if Present
(Expression
(Decl
)) then
21991 -- Variables in Persistent_BSS cannot be initialized, so
21992 -- turn off any initialization that might be caused by
21993 -- pragmas Initialize_Scalars or Normalize_Scalars.
21995 if Kill_Range_Check
(Expression
(Decl
)) then
21998 Name_Suppress_Initialization
,
21999 Pragma_Argument_Associations
=> New_List
(
22000 Make_Pragma_Argument_Association
(Loc
,
22001 Expression
=> New_Occurrence_Of
(Ent
, Loc
))));
22002 Insert_Before
(N
, Prag
);
22007 ("object for pragma% cannot have initialization", Arg1
);
22011 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
22013 ("object type for pragma% is not potentially persistent",
22018 Make_Linker_Section_Pragma
22019 (Ent
, Loc
, ".persistent.bss");
22020 Insert_After
(N
, Prag
);
22023 -- Case of use as configuration pragma with no arguments
22026 Check_Valid_Configuration_Pragma
;
22027 Persistent_BSS_Mode
:= True;
22029 end Persistent_BSS
;
22031 --------------------
22032 -- Rename_Pragma --
22033 --------------------
22035 -- pragma Rename_Pragma (
22036 -- [New_Name =>] IDENTIFIER,
22037 -- [Renamed =>] pragma_IDENTIFIER);
22039 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
22040 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22041 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
22045 Check_Valid_Configuration_Pragma
;
22046 Check_Arg_Count
(2);
22047 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
22048 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
22050 if Nkind
(New_Name
) /= N_Identifier
then
22051 Error_Pragma_Arg
("identifier expected", Arg1
);
22054 if Nkind
(Old_Name
) /= N_Identifier
then
22055 Error_Pragma_Arg
("identifier expected", Arg2
);
22058 -- The New_Name arg should not be an existing pragma (but we allow
22059 -- it; it's just a warning). The Old_Name arg must be an existing
22062 if Is_Pragma_Name
(Chars
(New_Name
)) then
22063 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
22066 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
22067 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
22070 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
22073 -----------------------------------
22074 -- Post/Post_Class/Postcondition --
22075 -----------------------------------
22077 -- pragma Post (Boolean_EXPRESSION);
22078 -- pragma Post_Class (Boolean_EXPRESSION);
22079 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
22080 -- [,[Message =>] String_EXPRESSION]);
22082 -- Characteristics:
22084 -- * Analysis - The annotation undergoes initial checks to verify
22085 -- the legal placement and context. Secondary checks preanalyze the
22088 -- Analyze_Pre_Post_Condition_In_Decl_Part
22090 -- * Expansion - The annotation is expanded during the expansion of
22091 -- the related subprogram [body] contract as performed in:
22093 -- Expand_Subprogram_Contract
22095 -- * Template - The annotation utilizes the generic template of the
22096 -- related subprogram [body] when it is:
22098 -- aspect on subprogram declaration
22099 -- aspect on stand-alone subprogram body
22100 -- pragma on stand-alone subprogram body
22102 -- The annotation must prepare its own template when it is:
22104 -- pragma on subprogram declaration
22106 -- * Globals - Capture of global references must occur after full
22109 -- * Instance - The annotation is instantiated automatically when
22110 -- the related generic subprogram [body] is instantiated except for
22111 -- the "pragma on subprogram declaration" case. In that scenario
22112 -- the annotation must instantiate itself.
22115 | Pragma_Post_Class
22116 | Pragma_Postcondition
22118 Analyze_Pre_Post_Condition
;
22120 --------------------------------
22121 -- Pre/Pre_Class/Precondition --
22122 --------------------------------
22124 -- pragma Pre (Boolean_EXPRESSION);
22125 -- pragma Pre_Class (Boolean_EXPRESSION);
22126 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
22127 -- [,[Message =>] String_EXPRESSION]);
22129 -- Characteristics:
22131 -- * Analysis - The annotation undergoes initial checks to verify
22132 -- the legal placement and context. Secondary checks preanalyze the
22135 -- Analyze_Pre_Post_Condition_In_Decl_Part
22137 -- * Expansion - The annotation is expanded during the expansion of
22138 -- the related subprogram [body] contract as performed in:
22140 -- Expand_Subprogram_Contract
22142 -- * Template - The annotation utilizes the generic template of the
22143 -- related subprogram [body] when it is:
22145 -- aspect on subprogram declaration
22146 -- aspect on stand-alone subprogram body
22147 -- pragma on stand-alone subprogram body
22149 -- The annotation must prepare its own template when it is:
22151 -- pragma on subprogram declaration
22153 -- * Globals - Capture of global references must occur after full
22156 -- * Instance - The annotation is instantiated automatically when
22157 -- the related generic subprogram [body] is instantiated except for
22158 -- the "pragma on subprogram declaration" case. In that scenario
22159 -- the annotation must instantiate itself.
22163 | Pragma_Precondition
22165 Analyze_Pre_Post_Condition
;
22171 -- pragma Predicate
22172 -- ([Entity =>] type_LOCAL_NAME,
22173 -- [Check =>] boolean_EXPRESSION);
22175 when Pragma_Predicate
=> Predicate
: declare
22182 Check_Arg_Count
(2);
22183 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22184 Check_Optional_Identifier
(Arg2
, Name_Check
);
22186 Check_Arg_Is_Local_Name
(Arg1
);
22188 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22189 Find_Type
(Type_Id
);
22190 Typ
:= Entity
(Type_Id
);
22192 if Typ
= Any_Type
then
22196 -- A Ghost_Predicate aspect is always Ghost with a mode inherited
22197 -- from the context. A Predicate pragma that applies to a Ghost
22198 -- entity becomes Ghost for the purposes of legality checks and
22199 -- removal of ignored Ghost code.
22201 if From_Aspect_Specification
(N
)
22202 and then Get_Aspect_Id
22203 (Chars
(Identifier
(Corresponding_Aspect
(N
))))
22204 = Aspect_Ghost_Predicate
22207 (N
, Name_To_Ghost_Mode
(Policy_In_Effect
(Name_Ghost
)));
22209 Mark_Ghost_Pragma
(N
, Typ
);
22212 -- The remaining processing is simply to link the pragma on to
22213 -- the rep item chain, for processing when the type is frozen.
22214 -- This is accomplished by a call to Rep_Item_Too_Late. We also
22215 -- mark the type as having predicates.
22217 -- If the current policy for predicate checking is Ignore mark the
22218 -- subtype accordingly. In the case of predicates we consider them
22219 -- enabled unless Ignore is specified (either directly or with a
22220 -- general Assertion_Policy pragma) to preserve existing warnings.
22222 Set_Has_Predicates
(Typ
);
22224 -- Indicate that the pragma must be processed at the point the
22225 -- type is frozen, as is done for the corresponding aspect.
22227 Set_Has_Delayed_Aspects
(Typ
);
22228 Set_Has_Delayed_Freeze
(Typ
);
22230 Set_Predicates_Ignored
(Typ
,
22231 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
22232 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
22235 -----------------------
22236 -- Predicate_Failure --
22237 -----------------------
22239 -- pragma Predicate_Failure
22240 -- ([Entity =>] type_LOCAL_NAME,
22241 -- [Message =>] string_EXPRESSION);
22243 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
22250 Check_Arg_Count
(2);
22251 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22252 Check_Optional_Identifier
(Arg2
, Name_Message
);
22254 Check_Arg_Is_Local_Name
(Arg1
);
22256 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22257 Find_Type
(Type_Id
);
22258 Typ
:= Entity
(Type_Id
);
22260 if Typ
= Any_Type
then
22264 -- A pragma that applies to a Ghost entity becomes Ghost for the
22265 -- purposes of legality checks and removal of ignored Ghost code.
22267 Mark_Ghost_Pragma
(N
, Typ
);
22269 -- The remaining processing is simply to link the pragma on to
22270 -- the rep item chain, for processing when the type is frozen.
22271 -- This is accomplished by a call to Rep_Item_Too_Late.
22273 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
22274 end Predicate_Failure
;
22280 -- pragma Preelaborate [(library_unit_NAME)];
22282 -- Set the flag Is_Preelaborated of program unit name entity
22284 when Pragma_Preelaborate
=> Preelaborate
: declare
22285 Pa
: constant Node_Id
:= Parent
(N
);
22286 Pk
: constant Node_Kind
:= Nkind
(Pa
);
22290 Check_Ada_83_Warning
;
22291 Check_Valid_Library_Unit_Pragma
;
22293 -- If N was rewritten as a null statement there is nothing more
22296 if Nkind
(N
) = N_Null_Statement
then
22300 Ent
:= Find_Lib_Unit_Name
;
22302 -- A pragma that applies to a Ghost entity becomes Ghost for the
22303 -- purposes of legality checks and removal of ignored Ghost code.
22305 Mark_Ghost_Pragma
(N
, Ent
);
22306 Check_Duplicate_Pragma
(Ent
);
22308 -- This filters out pragmas inside generic parents that show up
22309 -- inside instantiations. Pragmas that come from aspects in the
22310 -- unit are not ignored.
22312 if Present
(Ent
) then
22313 if Pk
= N_Package_Specification
22314 and then Present
(Generic_Parent
(Pa
))
22315 and then not From_Aspect_Specification
(N
)
22320 if not Debug_Flag_U
then
22321 Set_Is_Preelaborated
(Ent
);
22323 if Legacy_Elaboration_Checks
then
22324 Set_Suppress_Elaboration_Warnings
(Ent
);
22331 -------------------------------
22332 -- Prefix_Exception_Messages --
22333 -------------------------------
22335 -- pragma Prefix_Exception_Messages;
22337 when Pragma_Prefix_Exception_Messages
=>
22339 Check_Valid_Configuration_Pragma
;
22340 Check_Arg_Count
(0);
22341 Prefix_Exception_Messages
:= True;
22347 -- pragma Priority (EXPRESSION);
22349 when Pragma_Priority
=> Priority
: declare
22350 P
: constant Node_Id
:= Parent
(N
);
22355 Check_No_Identifiers
;
22356 Check_Arg_Count
(1);
22360 if Nkind
(P
) = N_Subprogram_Body
then
22361 Check_In_Main_Program
;
22363 Ent
:= Defining_Unit_Name
(Specification
(P
));
22365 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
22366 Ent
:= Defining_Identifier
(Ent
);
22369 Arg
:= Get_Pragma_Arg
(Arg1
);
22370 Analyze_And_Resolve
(Arg
, Standard_Integer
);
22374 if not Is_OK_Static_Expression
(Arg
) then
22375 Flag_Non_Static_Expr
22376 ("main subprogram priority is not static!", Arg
);
22379 -- If constraint error, then we already signalled an error
22381 elsif Raises_Constraint_Error
(Arg
) then
22384 -- Otherwise check in range except if Relaxed_RM_Semantics
22385 -- where we ignore the value if out of range.
22388 if not Relaxed_RM_Semantics
22389 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
22392 ("main subprogram priority is out of range", Arg1
);
22395 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
22399 -- Load an arbitrary entity from System.Tasking.Stages or
22400 -- System.Tasking.Restricted.Stages (depending on the
22401 -- supported profile) to make sure that one of these packages
22402 -- is implicitly with'ed, since we need to have the tasking
22403 -- run time active for the pragma Priority to have any effect.
22404 -- Previously we with'ed the package System.Tasking, but this
22405 -- package does not trigger the required initialization of the
22406 -- run-time library.
22408 if Restricted_Profile
then
22409 Discard_Node
(RTE
(RE_Activate_Restricted_Tasks
));
22411 Discard_Node
(RTE
(RE_Activate_Tasks
));
22414 -- Task or Protected, must be of type Integer
22416 elsif Nkind
(P
) in N_Protected_Definition | N_Task_Definition
then
22417 Arg
:= Get_Pragma_Arg
(Arg1
);
22418 Ent
:= Defining_Identifier
(Parent
(P
));
22420 -- The expression must be analyzed in the special manner
22421 -- described in "Handling of Default and Per-Object
22422 -- Expressions" in sem.ads.
22424 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
22426 if not Is_OK_Static_Expression
(Arg
) then
22427 Check_Restriction
(Static_Priorities
, Arg
);
22430 -- Anything else is incorrect
22436 -- Check duplicate pragma before we chain the pragma in the Rep
22437 -- Item chain of Ent.
22439 Check_Duplicate_Pragma
(Ent
);
22440 Record_Rep_Item
(Ent
, N
);
22443 -----------------------------------
22444 -- Priority_Specific_Dispatching --
22445 -----------------------------------
22447 -- pragma Priority_Specific_Dispatching (
22448 -- policy_IDENTIFIER,
22449 -- first_priority_EXPRESSION,
22450 -- last_priority_EXPRESSION);
22452 when Pragma_Priority_Specific_Dispatching
=>
22453 Priority_Specific_Dispatching
: declare
22454 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
22455 -- This is the entity System.Any_Priority;
22458 Lower_Bound
: Node_Id
;
22459 Upper_Bound
: Node_Id
;
22465 Check_Arg_Count
(3);
22466 Check_No_Identifiers
;
22467 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22468 Check_Valid_Configuration_Pragma
;
22469 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22470 DP
:= Fold_Upper
(Name_Buffer
(1));
22472 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
22473 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
22474 Lower_Val
:= Expr_Value
(Lower_Bound
);
22476 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
22477 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
22478 Upper_Val
:= Expr_Value
(Upper_Bound
);
22480 -- It is not allowed to use Task_Dispatching_Policy and
22481 -- Priority_Specific_Dispatching in the same partition.
22483 if Task_Dispatching_Policy
/= ' ' then
22484 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22486 ("pragma% incompatible with Task_Dispatching_Policy#");
22488 -- Check lower bound in range
22490 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
22492 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
22495 ("first_priority is out of range", Arg2
);
22497 -- Check upper bound in range
22499 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
22501 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
22504 ("last_priority is out of range", Arg3
);
22506 -- Check that the priority range is valid
22508 elsif Lower_Val
> Upper_Val
then
22510 ("last_priority_expression must be greater than or equal to "
22511 & "first_priority_expression");
22513 -- Store the new policy, but always preserve System_Location since
22514 -- we like the error message with the run-time name.
22517 -- Check overlapping in the priority ranges specified in other
22518 -- Priority_Specific_Dispatching pragmas within the same
22519 -- partition. We can only check those we know about.
22522 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
22524 if Specific_Dispatching
.Table
(J
).First_Priority
in
22525 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
22526 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
22527 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
22530 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
22532 ("priority range overlaps with "
22533 & "Priority_Specific_Dispatching#");
22537 -- The use of Priority_Specific_Dispatching is incompatible
22538 -- with Task_Dispatching_Policy.
22540 if Task_Dispatching_Policy
/= ' ' then
22541 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22543 ("Priority_Specific_Dispatching incompatible "
22544 & "with Task_Dispatching_Policy#");
22547 -- The use of Priority_Specific_Dispatching forces ceiling
22550 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
22551 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
22553 ("Priority_Specific_Dispatching incompatible "
22554 & "with Locking_Policy#");
22556 -- Set the Ceiling_Locking policy, but preserve System_Location
22557 -- since we like the error message with the run time name.
22560 Locking_Policy
:= 'C';
22562 if Locking_Policy_Sloc
/= System_Location
then
22563 Locking_Policy_Sloc
:= Loc
;
22567 -- Add entry in the table
22569 Specific_Dispatching
.Append
22570 ((Dispatching_Policy
=> DP
,
22571 First_Priority
=> UI_To_Int
(Lower_Val
),
22572 Last_Priority
=> UI_To_Int
(Upper_Val
),
22573 Pragma_Loc
=> Loc
));
22575 end Priority_Specific_Dispatching
;
22581 -- pragma Profile (profile_IDENTIFIER);
22583 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
22585 when Pragma_Profile
=>
22587 Check_Arg_Count
(1);
22588 Check_Valid_Configuration_Pragma
;
22589 Check_No_Identifiers
;
22592 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22595 if Nkind
(Argx
) /= N_Identifier
then
22597 ("argument of pragma Profile must be an identifier", N
);
22599 elsif Chars
(Argx
) = Name_Ravenscar
then
22600 Set_Ravenscar_Profile
(Ravenscar
, N
);
22602 elsif Chars
(Argx
) = Name_Jorvik
then
22603 Set_Ravenscar_Profile
(Jorvik
, N
);
22605 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
22606 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
22608 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
22609 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
22611 elsif Chars
(Argx
) = Name_Restricted
then
22612 Set_Profile_Restrictions
22614 N
, Warn
=> Treat_Restrictions_As_Warnings
);
22616 elsif Chars
(Argx
) = Name_Rational
then
22617 Set_Rational_Profile
;
22619 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
22620 Set_Profile_Restrictions
22621 (No_Implementation_Extensions
,
22622 N
, Warn
=> Treat_Restrictions_As_Warnings
);
22625 Error_Pragma_Arg
("& is not a valid profile", Argx
);
22629 ----------------------
22630 -- Profile_Warnings --
22631 ----------------------
22633 -- pragma Profile_Warnings (profile_IDENTIFIER);
22635 -- profile_IDENTIFIER => Restricted | Ravenscar
22637 when Pragma_Profile_Warnings
=>
22639 Check_Arg_Count
(1);
22640 Check_Valid_Configuration_Pragma
;
22641 Check_No_Identifiers
;
22644 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22647 if Chars
(Argx
) = Name_Ravenscar
then
22648 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
22650 elsif Chars
(Argx
) = Name_Restricted
then
22651 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
22653 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
22654 Set_Profile_Restrictions
22655 (No_Implementation_Extensions
, N
, Warn
=> True);
22658 Error_Pragma_Arg
("& is not a valid profile", Argx
);
22662 --------------------------
22663 -- Propagate_Exceptions --
22664 --------------------------
22666 -- pragma Propagate_Exceptions;
22668 -- Note: this pragma is obsolete and has no effect
22670 when Pragma_Propagate_Exceptions
=>
22672 Check_Arg_Count
(0);
22674 if Warn_On_Obsolescent_Feature
then
22676 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
22677 "and has no effect?j?", N
);
22680 -----------------------------
22681 -- Provide_Shift_Operators --
22682 -----------------------------
22684 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
22686 when Pragma_Provide_Shift_Operators
=>
22687 Provide_Shift_Operators
: declare
22690 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
22691 -- Insert declaration and pragma Instrinsic for named shift op
22693 ----------------------------
22694 -- Declare_Shift_Operator --
22695 ----------------------------
22697 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
22703 Make_Subprogram_Declaration
(Loc
,
22704 Make_Function_Specification
(Loc
,
22705 Defining_Unit_Name
=>
22706 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
22708 Result_Definition
=>
22709 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
22711 Parameter_Specifications
=> New_List
(
22712 Make_Parameter_Specification
(Loc
,
22713 Defining_Identifier
=>
22714 Make_Defining_Identifier
(Loc
, Name_Value
),
22716 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
22718 Make_Parameter_Specification
(Loc
,
22719 Defining_Identifier
=>
22720 Make_Defining_Identifier
(Loc
, Name_Amount
),
22722 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
22726 Chars
=> Name_Import
,
22727 Pragma_Argument_Associations
=> New_List
(
22728 Make_Pragma_Argument_Association
(Loc
,
22729 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
22730 Make_Pragma_Argument_Association
(Loc
,
22731 Expression
=> Make_Identifier
(Loc
, Nam
))));
22733 Insert_After
(N
, Import
);
22734 Insert_After
(N
, Func
);
22735 end Declare_Shift_Operator
;
22737 -- Start of processing for Provide_Shift_Operators
22741 Check_Arg_Count
(1);
22742 Check_Arg_Is_Local_Name
(Arg1
);
22744 Arg1
:= Get_Pragma_Arg
(Arg1
);
22746 -- We must have an entity name
22748 if not Is_Entity_Name
(Arg1
) then
22750 ("pragma % must apply to integer first subtype", Arg1
);
22753 -- If no Entity, means there was a prior error so ignore
22755 if Present
(Entity
(Arg1
)) then
22756 Ent
:= Entity
(Arg1
);
22758 -- Apply error checks
22760 if not Is_First_Subtype
(Ent
) then
22762 ("cannot apply pragma %",
22763 "\& is not a first subtype",
22766 elsif not Is_Integer_Type
(Ent
) then
22768 ("cannot apply pragma %",
22769 "\& is not an integer type",
22772 elsif Has_Shift_Operator
(Ent
) then
22774 ("cannot apply pragma %",
22775 "\& already has declared shift operators",
22778 elsif Is_Frozen
(Ent
) then
22780 ("pragma % appears too late",
22781 "\& is already frozen",
22785 -- Now declare the operators. We do this during analysis rather
22786 -- than expansion, since we want the operators available if we
22787 -- are operating in -gnatc mode.
22789 Declare_Shift_Operator
(Name_Rotate_Left
);
22790 Declare_Shift_Operator
(Name_Rotate_Right
);
22791 Declare_Shift_Operator
(Name_Shift_Left
);
22792 Declare_Shift_Operator
(Name_Shift_Right
);
22793 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
22795 end Provide_Shift_Operators
;
22801 -- pragma Psect_Object (
22802 -- [Internal =>] LOCAL_NAME,
22803 -- [, [External =>] EXTERNAL_SYMBOL]
22804 -- [, [Size =>] EXTERNAL_SYMBOL]);
22806 when Pragma_Common_Object
22807 | Pragma_Psect_Object
22809 Psect_Object
: declare
22810 Args
: Args_List
(1 .. 3);
22811 Names
: constant Name_List
(1 .. 3) := (
22816 Internal
: Node_Id
renames Args
(1);
22817 External
: Node_Id
renames Args
(2);
22818 Size
: Node_Id
renames Args
(3);
22820 Def_Id
: Entity_Id
;
22822 procedure Check_Arg
(Arg
: Node_Id
);
22823 -- Checks that argument is either a string literal or an
22824 -- identifier, and posts error message if not.
22830 procedure Check_Arg
(Arg
: Node_Id
) is
22832 if Nkind
(Original_Node
(Arg
)) not in
22833 N_String_Literal | N_Identifier
22836 ("inappropriate argument for pragma %", Arg
);
22840 -- Start of processing for Common_Object/Psect_Object
22844 Gather_Associations
(Names
, Args
);
22845 Process_Extended_Import_Export_Internal_Arg
(Internal
);
22847 Def_Id
:= Entity
(Internal
);
22849 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
22851 ("pragma% must designate an object", Internal
);
22854 Check_Arg
(Internal
);
22856 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
22858 ("cannot use pragma% for imported/exported object",
22862 if Is_Concurrent_Type
(Etype
(Internal
)) then
22864 ("cannot specify pragma % for task/protected object",
22868 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
22870 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
22872 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
22875 if Ekind
(Def_Id
) = E_Constant
then
22877 ("cannot specify pragma % for a constant", Internal
);
22880 if Is_Record_Type
(Etype
(Internal
)) then
22886 Ent
:= First_Entity
(Etype
(Internal
));
22887 while Present
(Ent
) loop
22888 Decl
:= Declaration_Node
(Ent
);
22890 if Ekind
(Ent
) = E_Component
22891 and then Nkind
(Decl
) = N_Component_Declaration
22892 and then Present
(Expression
(Decl
))
22893 and then Warn_On_Export_Import
22896 ("?x?object for pragma % has defaults", Internal
);
22906 if Present
(Size
) then
22910 if Present
(External
) then
22911 Check_Arg_Is_External_Name
(External
);
22914 -- If all error tests pass, link pragma on to the rep item chain
22916 Record_Rep_Item
(Def_Id
, N
);
22923 -- pragma Pure [(library_unit_NAME)];
22925 when Pragma_Pure
=> Pure
: declare
22929 Check_Ada_83_Warning
;
22931 -- If the pragma comes from a subprogram instantiation, nothing to
22932 -- check, this can happen at any level of nesting.
22934 if Is_Wrapper_Package
(Current_Scope
) then
22938 Check_Valid_Library_Unit_Pragma
;
22940 -- If N was rewritten as a null statement there is nothing more
22943 if Nkind
(N
) = N_Null_Statement
then
22947 Ent
:= Find_Lib_Unit_Name
;
22949 -- A pragma that applies to a Ghost entity becomes Ghost for the
22950 -- purposes of legality checks and removal of ignored Ghost code.
22952 Mark_Ghost_Pragma
(N
, Ent
);
22954 if not Debug_Flag_U
then
22956 Set_Has_Pragma_Pure
(Ent
);
22958 if Legacy_Elaboration_Checks
then
22959 Set_Suppress_Elaboration_Warnings
(Ent
);
22964 -------------------
22965 -- Pure_Function --
22966 -------------------
22968 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22970 when Pragma_Pure_Function
=> Pure_Function
: declare
22971 Def_Id
: Entity_Id
;
22974 Effective
: Boolean := False;
22975 Orig_Def
: Entity_Id
;
22976 Same_Decl
: Boolean := False;
22980 Check_Arg_Count
(1);
22981 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22982 Check_Arg_Is_Local_Name
(Arg1
);
22983 E_Id
:= Get_Pragma_Arg
(Arg1
);
22985 if Etype
(E_Id
) = Any_Type
then
22989 -- Loop through homonyms (overloadings) of referenced entity
22991 E
:= Entity
(E_Id
);
22993 Analyze_If_Present
(Pragma_Side_Effects
);
22995 -- A function with side effects shall not have a Pure_Function
22996 -- aspect or pragma (SPARK RM 6.1.11(5)).
22998 if Is_Function_With_Side_Effects
(E
) then
23000 ("pragma % incompatible with ""Side_Effects""");
23003 -- A pragma that applies to a Ghost entity becomes Ghost for the
23004 -- purposes of legality checks and removal of ignored Ghost code.
23006 Mark_Ghost_Pragma
(N
, E
);
23008 if Present
(E
) then
23010 Def_Id
:= Get_Base_Subprogram
(E
);
23012 if Ekind
(Def_Id
) not in
23013 E_Function | E_Generic_Function | E_Operator
23016 ("pragma% requires a function name", Arg1
);
23019 -- When we have a generic function we must jump up a level
23020 -- to the declaration of the wrapper package itself.
23022 Orig_Def
:= Def_Id
;
23024 if Is_Generic_Instance
(Def_Id
) then
23025 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
23026 Orig_Def
:= Parent
(Orig_Def
);
23030 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
23032 Set_Is_Pure
(Def_Id
);
23034 if not Has_Pragma_Pure_Function
(Def_Id
) then
23035 Set_Has_Pragma_Pure_Function
(Def_Id
);
23040 exit when From_Aspect_Specification
(N
);
23042 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
23046 and then Warn_On_Redundant_Constructs
23049 ("pragma Pure_Function on& is redundant?r?",
23052 elsif not Same_Decl
then
23054 ("pragma% argument must be in same declarative part",
23060 --------------------
23061 -- Queuing_Policy --
23062 --------------------
23064 -- pragma Queuing_Policy (policy_IDENTIFIER);
23066 when Pragma_Queuing_Policy
=> declare
23070 Check_Ada_83_Warning
;
23071 Check_Arg_Count
(1);
23072 Check_No_Identifiers
;
23073 Check_Arg_Is_Queuing_Policy
(Arg1
);
23074 Check_Valid_Configuration_Pragma
;
23075 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23076 QP
:= Fold_Upper
(Name_Buffer
(1));
23078 if Queuing_Policy
/= ' '
23079 and then Queuing_Policy
/= QP
23081 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
23082 Error_Pragma
("queuing policy incompatible with policy#");
23084 -- Set new policy, but always preserve System_Location since we
23085 -- like the error message with the run time name.
23088 Queuing_Policy
:= QP
;
23090 if Queuing_Policy_Sloc
/= System_Location
then
23091 Queuing_Policy_Sloc
:= Loc
;
23100 -- pragma Rational, for compatibility with foreign compiler
23102 when Pragma_Rational
=>
23103 Set_Rational_Profile
;
23105 ---------------------
23106 -- Refined_Depends --
23107 ---------------------
23109 -- pragma Refined_Depends (DEPENDENCY_RELATION);
23111 -- DEPENDENCY_RELATION ::=
23113 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
23115 -- DEPENDENCY_CLAUSE ::=
23116 -- OUTPUT_LIST =>[+] INPUT_LIST
23117 -- | NULL_DEPENDENCY_CLAUSE
23119 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
23121 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
23123 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
23125 -- OUTPUT ::= NAME | FUNCTION_RESULT
23128 -- where FUNCTION_RESULT is a function Result attribute_reference
23130 -- Characteristics:
23132 -- * Analysis - The annotation undergoes initial checks to verify
23133 -- the legal placement and context. Secondary checks fully analyze
23134 -- the dependency clauses/global list in:
23136 -- Analyze_Refined_Depends_In_Decl_Part
23138 -- * Expansion - None.
23140 -- * Template - The annotation utilizes the generic template of the
23141 -- related subprogram body.
23143 -- * Globals - Capture of global references must occur after full
23146 -- * Instance - The annotation is instantiated automatically when
23147 -- the related generic subprogram body is instantiated.
23149 when Pragma_Refined_Depends
=> Refined_Depends
: declare
23150 Body_Id
: Entity_Id
;
23152 Spec_Id
: Entity_Id
;
23155 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23159 -- Chain the pragma on the contract for further processing by
23160 -- Analyze_Refined_Depends_In_Decl_Part.
23162 Add_Contract_Item
(N
, Body_Id
);
23164 -- The legality checks of pragmas Refined_Depends and
23165 -- Refined_Global are affected by the SPARK mode in effect and
23166 -- the volatility of the context. In addition these two pragmas
23167 -- are subject to an inherent order:
23169 -- 1) Refined_Global
23170 -- 2) Refined_Depends
23172 -- Analyze all these pragmas in the order outlined above
23174 Analyze_If_Present
(Pragma_SPARK_Mode
);
23175 Analyze_If_Present
(Pragma_Volatile_Function
);
23176 Analyze_If_Present
(Pragma_Side_Effects
);
23177 Analyze_If_Present
(Pragma_Refined_Global
);
23178 Analyze_Refined_Depends_In_Decl_Part
(N
);
23180 end Refined_Depends
;
23182 --------------------
23183 -- Refined_Global --
23184 --------------------
23186 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
23188 -- GLOBAL_SPECIFICATION ::=
23191 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
23193 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
23195 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
23196 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
23197 -- GLOBAL_ITEM ::= NAME
23199 -- Characteristics:
23201 -- * Analysis - The annotation undergoes initial checks to verify
23202 -- the legal placement and context. Secondary checks fully analyze
23203 -- the dependency clauses/global list in:
23205 -- Analyze_Refined_Global_In_Decl_Part
23207 -- * Expansion - None.
23209 -- * Template - The annotation utilizes the generic template of the
23210 -- related subprogram body.
23212 -- * Globals - Capture of global references must occur after full
23215 -- * Instance - The annotation is instantiated automatically when
23216 -- the related generic subprogram body is instantiated.
23218 when Pragma_Refined_Global
=> Refined_Global
: declare
23219 Body_Id
: Entity_Id
;
23221 Spec_Id
: Entity_Id
;
23224 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23228 -- Chain the pragma on the contract for further processing by
23229 -- Analyze_Refined_Global_In_Decl_Part.
23231 Add_Contract_Item
(N
, Body_Id
);
23233 -- The legality checks of pragmas Refined_Depends and
23234 -- Refined_Global are affected by the SPARK mode in effect and
23235 -- the volatility of the context. In addition these two pragmas
23236 -- are subject to an inherent order:
23238 -- 1) Refined_Global
23239 -- 2) Refined_Depends
23241 -- Analyze all these pragmas in the order outlined above
23243 Analyze_If_Present
(Pragma_SPARK_Mode
);
23244 Analyze_If_Present
(Pragma_Volatile_Function
);
23245 Analyze_If_Present
(Pragma_Side_Effects
);
23246 Analyze_Refined_Global_In_Decl_Part
(N
);
23247 Analyze_If_Present
(Pragma_Refined_Depends
);
23249 end Refined_Global
;
23255 -- pragma Refined_Post (boolean_EXPRESSION);
23257 -- Characteristics:
23259 -- * Analysis - The annotation is fully analyzed immediately upon
23260 -- elaboration as it cannot forward reference entities.
23262 -- * Expansion - The annotation is expanded during the expansion of
23263 -- the related subprogram body contract as performed in:
23265 -- Expand_Subprogram_Contract
23267 -- * Template - The annotation utilizes the generic template of the
23268 -- related subprogram body.
23270 -- * Globals - Capture of global references must occur after full
23273 -- * Instance - The annotation is instantiated automatically when
23274 -- the related generic subprogram body is instantiated.
23276 when Pragma_Refined_Post
=> Refined_Post
: declare
23277 Body_Id
: Entity_Id
;
23279 Spec_Id
: Entity_Id
;
23282 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23284 -- Fully analyze the pragma when it appears inside a subprogram
23285 -- body because it cannot benefit from forward references.
23289 -- Chain the pragma on the contract for completeness
23291 Add_Contract_Item
(N
, Body_Id
);
23293 -- The legality checks of pragma Refined_Post are affected by
23294 -- the SPARK mode in effect and the volatility of the context.
23295 -- Analyze all pragmas in a specific order.
23297 Analyze_If_Present
(Pragma_SPARK_Mode
);
23298 Analyze_If_Present
(Pragma_Volatile_Function
);
23299 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
23301 -- Currently it is not possible to inline pre/postconditions on
23302 -- a subprogram subject to pragma Inline_Always.
23304 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
23308 -------------------
23309 -- Refined_State --
23310 -------------------
23312 -- pragma Refined_State (REFINEMENT_LIST);
23314 -- REFINEMENT_LIST ::=
23315 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
23317 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
23319 -- CONSTITUENT_LIST ::=
23322 -- | (CONSTITUENT {, CONSTITUENT})
23324 -- CONSTITUENT ::= object_NAME | state_NAME
23326 -- Characteristics:
23328 -- * Analysis - The annotation undergoes initial checks to verify
23329 -- the legal placement and context. Secondary checks preanalyze the
23330 -- refinement clauses in:
23332 -- Analyze_Refined_State_In_Decl_Part
23334 -- * Expansion - None.
23336 -- * Template - The annotation utilizes the template of the related
23339 -- * Globals - Capture of global references must occur after full
23342 -- * Instance - The annotation is instantiated automatically when
23343 -- the related generic package body is instantiated.
23345 when Pragma_Refined_State
=> Refined_State
: declare
23346 Pack_Decl
: Node_Id
;
23347 Spec_Id
: Entity_Id
;
23351 Check_No_Identifiers
;
23352 Check_Arg_Count
(1);
23354 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
23356 if Nkind
(Pack_Decl
) /= N_Package_Body
then
23360 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
23362 -- A pragma that applies to a Ghost entity becomes Ghost for the
23363 -- purposes of legality checks and removal of ignored Ghost code.
23365 Mark_Ghost_Pragma
(N
, Spec_Id
);
23367 -- Chain the pragma on the contract for further processing by
23368 -- Analyze_Refined_State_In_Decl_Part.
23370 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
23372 -- The legality checks of pragma Refined_State are affected by the
23373 -- SPARK mode in effect. Analyze all pragmas in a specific order.
23375 Analyze_If_Present
(Pragma_SPARK_Mode
);
23377 -- State refinement is allowed only when the corresponding package
23378 -- declaration has non-null pragma Abstract_State (SPARK RM
23381 if No
(Abstract_States
(Spec_Id
))
23382 or else Has_Null_Abstract_State
(Spec_Id
)
23385 ("useless refinement, package & does not define abstract "
23386 & "states", N
, Spec_Id
);
23391 -----------------------
23392 -- Relative_Deadline --
23393 -----------------------
23395 -- pragma Relative_Deadline (time_span_EXPRESSION);
23397 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
23398 P
: constant Node_Id
:= Parent
(N
);
23403 Check_No_Identifiers
;
23404 Check_Arg_Count
(1);
23406 Arg
:= Get_Pragma_Arg
(Arg1
);
23408 -- The expression must be analyzed in the special manner described
23409 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
23411 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
23415 if Nkind
(P
) = N_Subprogram_Body
then
23416 Check_In_Main_Program
;
23418 -- Only Task and subprogram cases allowed
23420 elsif Nkind
(P
) /= N_Task_Definition
then
23424 -- Check duplicate pragma before we set the corresponding flag
23426 if Has_Relative_Deadline_Pragma
(P
) then
23427 Error_Pragma
("duplicate pragma% not allowed");
23430 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
23431 -- Relative_Deadline pragma node cannot be inserted in the Rep
23432 -- Item chain of Ent since it is rewritten by the expander as a
23433 -- procedure call statement that will break the chain.
23435 Set_Has_Relative_Deadline_Pragma
(P
);
23436 end Relative_Deadline
;
23438 ------------------------
23439 -- Remote_Access_Type --
23440 ------------------------
23442 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
23444 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
23449 Check_Arg_Count
(1);
23450 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23451 Check_Arg_Is_Local_Name
(Arg1
);
23453 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
23455 -- A pragma that applies to a Ghost entity becomes Ghost for the
23456 -- purposes of legality checks and removal of ignored Ghost code.
23458 Mark_Ghost_Pragma
(N
, E
);
23460 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
23461 and then Ekind
(E
) = E_General_Access_Type
23462 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
23463 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
23465 and then Is_Valid_Remote_Object_Type
23466 (Root_Type
(Directly_Designated_Type
(E
)))
23468 Set_Is_Remote_Types
(E
);
23472 ("pragma% applies only to formal access-to-class-wide types",
23475 end Remote_Access_Type
;
23477 ---------------------------
23478 -- Remote_Call_Interface --
23479 ---------------------------
23481 -- pragma Remote_Call_Interface [(library_unit_NAME)];
23483 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
23484 Cunit_Node
: Node_Id
;
23485 Cunit_Ent
: Entity_Id
;
23489 Check_Ada_83_Warning
;
23490 Check_Valid_Library_Unit_Pragma
;
23492 -- If N was rewritten as a null statement there is nothing more
23495 if Nkind
(N
) = N_Null_Statement
then
23499 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23500 K
:= Nkind
(Unit
(Cunit_Node
));
23501 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23503 -- A pragma that applies to a Ghost entity becomes Ghost for the
23504 -- purposes of legality checks and removal of ignored Ghost code.
23506 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23508 if K
= N_Package_Declaration
23509 or else K
= N_Generic_Package_Declaration
23510 or else K
= N_Subprogram_Declaration
23511 or else K
= N_Generic_Subprogram_Declaration
23512 or else (K
= N_Subprogram_Body
23513 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
23518 "pragma% must apply to package or subprogram declaration");
23521 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
23522 end Remote_Call_Interface
;
23528 -- pragma Remote_Types [(library_unit_NAME)];
23530 when Pragma_Remote_Types
=> Remote_Types
: declare
23531 Cunit_Node
: Node_Id
;
23532 Cunit_Ent
: Entity_Id
;
23535 Check_Ada_83_Warning
;
23536 Check_Valid_Library_Unit_Pragma
;
23538 -- If N was rewritten as a null statement there is nothing more
23541 if Nkind
(N
) = N_Null_Statement
then
23545 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23546 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23548 -- A pragma that applies to a Ghost entity becomes Ghost for the
23549 -- purposes of legality checks and removal of ignored Ghost code.
23551 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23553 if Nkind
(Unit
(Cunit_Node
)) not in
23554 N_Package_Declaration | N_Generic_Package_Declaration
23557 ("pragma% can only apply to a package declaration");
23560 Set_Is_Remote_Types
(Cunit_Ent
);
23567 -- pragma Ravenscar;
23569 when Pragma_Ravenscar
=>
23571 Check_Arg_Count
(0);
23572 Check_Valid_Configuration_Pragma
;
23573 Set_Ravenscar_Profile
(Ravenscar
, N
);
23575 if Warn_On_Obsolescent_Feature
then
23577 ("pragma Ravenscar is an obsolescent feature?j?", N
);
23579 ("|use pragma Profile (Ravenscar) instead?j?", N
);
23582 -------------------------
23583 -- Restricted_Run_Time --
23584 -------------------------
23586 -- pragma Restricted_Run_Time;
23588 when Pragma_Restricted_Run_Time
=>
23590 Check_Arg_Count
(0);
23591 Check_Valid_Configuration_Pragma
;
23592 Set_Profile_Restrictions
23593 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
23595 if Warn_On_Obsolescent_Feature
then
23597 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
23600 ("|use pragma Profile (Restricted) instead?j?", N
);
23607 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
23610 -- restriction_IDENTIFIER
23611 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23613 when Pragma_Restrictions
=>
23614 Process_Restrictions_Or_Restriction_Warnings
23615 (Warn
=> Treat_Restrictions_As_Warnings
);
23617 --------------------------
23618 -- Restriction_Warnings --
23619 --------------------------
23621 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
23624 -- restriction_IDENTIFIER
23625 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23627 when Pragma_Restriction_Warnings
=>
23629 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
23635 -- pragma Reviewable;
23637 when Pragma_Reviewable
=>
23638 Check_Ada_83_Warning
;
23639 Check_Arg_Count
(0);
23641 -- Call dummy debugging function rv. This is done to assist front
23642 -- end debugging. By placing a Reviewable pragma in the source
23643 -- program, a breakpoint on rv catches this place in the source,
23644 -- allowing convenient stepping to the point of interest.
23648 --------------------------
23649 -- Secondary_Stack_Size --
23650 --------------------------
23652 -- pragma Secondary_Stack_Size (EXPRESSION);
23654 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
23655 P
: constant Node_Id
:= Parent
(N
);
23661 Check_No_Identifiers
;
23662 Check_Arg_Count
(1);
23664 if Nkind
(P
) = N_Task_Definition
then
23665 Arg
:= Get_Pragma_Arg
(Arg1
);
23666 Ent
:= Defining_Identifier
(Parent
(P
));
23668 -- The expression must be analyzed in the special manner
23669 -- described in "Handling of Default Expressions" in sem.ads.
23671 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23673 -- The pragma cannot appear if the No_Secondary_Stack
23674 -- restriction is in effect.
23676 Check_Restriction
(No_Secondary_Stack
, Arg
);
23678 -- Anything else is incorrect
23684 -- Check duplicate pragma before we chain the pragma in the Rep
23685 -- Item chain of Ent.
23687 Check_Duplicate_Pragma
(Ent
);
23688 Record_Rep_Item
(Ent
, N
);
23689 end Secondary_Stack_Size
;
23691 --------------------------
23692 -- Short_Circuit_And_Or --
23693 --------------------------
23695 -- pragma Short_Circuit_And_Or;
23697 when Pragma_Short_Circuit_And_Or
=>
23699 Check_Arg_Count
(0);
23700 Check_Valid_Configuration_Pragma
;
23701 Short_Circuit_And_Or
:= True;
23703 -------------------
23704 -- Share_Generic --
23705 -------------------
23707 -- pragma Share_Generic (GNAME {, GNAME});
23709 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23711 when Pragma_Share_Generic
=>
23713 Process_Generic_List
;
23719 -- pragma Shared (LOCAL_NAME);
23721 when Pragma_Shared
=>
23723 Process_Atomic_Independent_Shared_Volatile
;
23725 --------------------
23726 -- Shared_Passive --
23727 --------------------
23729 -- pragma Shared_Passive [(library_unit_NAME)];
23731 -- Set the flag Is_Shared_Passive of program unit name entity
23733 when Pragma_Shared_Passive
=> Shared_Passive
: declare
23734 Cunit_Node
: Node_Id
;
23735 Cunit_Ent
: Entity_Id
;
23738 Check_Ada_83_Warning
;
23739 Check_Valid_Library_Unit_Pragma
;
23741 -- If N was rewritten as a null statement there is nothing more
23744 if Nkind
(N
) = N_Null_Statement
then
23748 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23749 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23751 -- A pragma that applies to a Ghost entity becomes Ghost for the
23752 -- purposes of legality checks and removal of ignored Ghost code.
23754 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23756 if Nkind
(Unit
(Cunit_Node
)) not in
23757 N_Package_Declaration | N_Generic_Package_Declaration
23760 ("pragma% can only apply to a package declaration");
23763 Set_Is_Shared_Passive
(Cunit_Ent
);
23764 end Shared_Passive
;
23766 -----------------------
23767 -- Short_Descriptors --
23768 -----------------------
23770 -- pragma Short_Descriptors;
23772 -- Recognize and validate, but otherwise ignore
23774 when Pragma_Short_Descriptors
=>
23776 Check_Arg_Count
(0);
23777 Check_Valid_Configuration_Pragma
;
23783 -- pragma Side_Effects [ (boolean_EXPRESSION) ];
23785 -- Characteristics:
23787 -- * Analysis - The annotation is fully analyzed immediately upon
23788 -- elaboration as its expression must be static.
23790 -- * Expansion - None.
23792 -- * Template - The annotation utilizes the generic template of the
23793 -- related subprogram [body] when it is:
23795 -- aspect on subprogram declaration
23796 -- aspect on stand-alone subprogram body
23797 -- pragma on stand-alone subprogram body
23799 -- The annotation must prepare its own template when it is:
23801 -- pragma on subprogram declaration
23803 -- * Globals - Capture of global references must occur after full
23806 -- * Instance - The annotation is instantiated automatically when
23807 -- the related generic subprogram [body] is instantiated except for
23808 -- the "pragma on subprogram declaration" case. In that scenario
23809 -- the annotation must instantiate itself.
23811 when Pragma_Side_Effects
=> Side_Effects
: declare
23812 Subp_Decl
: Node_Id
;
23813 Spec_Id
: Entity_Id
;
23814 Over_Id
: Entity_Id
;
23818 Check_No_Identifiers
;
23819 Check_At_Most_N_Arguments
(1);
23822 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23824 -- Abstract subprogram declaration
23826 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23829 -- Generic subprogram declaration
23831 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23834 -- Body acts as spec
23836 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23837 and then No
(Corresponding_Spec
(Subp_Decl
))
23841 -- Body stub acts as spec
23843 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23844 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23848 -- Subprogram declaration
23850 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23853 -- Otherwise the pragma is associated with an illegal construct
23856 Error_Pragma
("pragma % must apply to a subprogram");
23859 if Nkind
(Specification
(Subp_Decl
)) /= N_Function_Specification
23861 Error_Pragma
("pragma % must apply to a function");
23864 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23866 -- Chain the pragma on the contract for completeness
23868 Add_Contract_Item
(N
, Spec_Id
);
23870 -- A function with side effects cannot override a function without
23871 -- side effects (SPARK RM 7.1.2(16)). Overriding checks are
23872 -- usually performed in New_Overloaded_Entity, however at
23873 -- that point the pragma has not been processed yet.
23875 Over_Id
:= Overridden_Operation
(Spec_Id
);
23877 if Present
(Over_Id
)
23878 and then not Is_Function_With_Side_Effects
(Over_Id
)
23881 ("incompatible declaration of side effects for function",
23884 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23886 ("\& declared # with Side_Effects value False",
23889 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23891 ("\overridden # with Side_Effects value True",
23895 -- Analyze the Boolean expression (if any)
23897 if Present
(Arg1
) then
23898 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23902 ------------------------------
23903 -- Simple_Storage_Pool_Type --
23904 ------------------------------
23906 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23908 when Pragma_Simple_Storage_Pool_Type
=>
23909 Simple_Storage_Pool_Type
: declare
23915 Check_Arg_Count
(1);
23916 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23918 Type_Id
:= Get_Pragma_Arg
(Arg1
);
23919 Find_Type
(Type_Id
);
23920 Typ
:= Entity
(Type_Id
);
23922 if Typ
= Any_Type
then
23926 -- A pragma that applies to a Ghost entity becomes Ghost for the
23927 -- purposes of legality checks and removal of ignored Ghost code.
23929 Mark_Ghost_Pragma
(N
, Typ
);
23931 -- We require the pragma to apply to a type declared in a package
23932 -- declaration, but not (immediately) within a package body.
23934 if Ekind
(Current_Scope
) /= E_Package
23935 or else In_Package_Body
(Current_Scope
)
23938 ("pragma% can only apply to type declared immediately "
23939 & "within a package declaration");
23942 -- A simple storage pool type must be an immutably limited record
23943 -- or private type. If the pragma is given for a private type,
23944 -- the full type is similarly restricted (which is checked later
23945 -- in Freeze_Entity).
23947 if Is_Record_Type
(Typ
)
23948 and then not Is_Inherently_Limited_Type
(Typ
)
23951 ("pragma% can only apply to explicitly limited record type");
23953 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
23955 ("pragma% can only apply to a private type that is limited");
23957 elsif not Is_Record_Type
(Typ
)
23958 and then not Is_Private_Type
(Typ
)
23961 ("pragma% can only apply to limited record or private type");
23964 Record_Rep_Item
(Typ
, N
);
23965 end Simple_Storage_Pool_Type
;
23967 ----------------------
23968 -- Source_File_Name --
23969 ----------------------
23971 -- There are five forms for this pragma:
23973 -- pragma Source_File_Name (
23974 -- [UNIT_NAME =>] unit_NAME,
23975 -- BODY_FILE_NAME => STRING_LITERAL
23976 -- [, [INDEX =>] INTEGER_LITERAL]);
23978 -- pragma Source_File_Name (
23979 -- [UNIT_NAME =>] unit_NAME,
23980 -- SPEC_FILE_NAME => STRING_LITERAL
23981 -- [, [INDEX =>] INTEGER_LITERAL]);
23983 -- pragma Source_File_Name (
23984 -- BODY_FILE_NAME => STRING_LITERAL
23985 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23986 -- [, CASING => CASING_SPEC]);
23988 -- pragma Source_File_Name (
23989 -- SPEC_FILE_NAME => STRING_LITERAL
23990 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23991 -- [, CASING => CASING_SPEC]);
23993 -- pragma Source_File_Name (
23994 -- SUBUNIT_FILE_NAME => STRING_LITERAL
23995 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23996 -- [, CASING => CASING_SPEC]);
23998 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
24000 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
24001 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
24002 -- only be used when no project file is used, while SFNP can only be
24003 -- used when a project file is used.
24005 -- No processing here. Processing was completed during parsing, since
24006 -- we need to have file names set as early as possible. Units are
24007 -- loaded well before semantic processing starts.
24009 -- The only processing we defer to this point is the check for
24010 -- correct placement.
24012 when Pragma_Source_File_Name
=>
24014 Check_Valid_Configuration_Pragma
;
24016 ------------------------------
24017 -- Source_File_Name_Project --
24018 ------------------------------
24020 -- See Source_File_Name for syntax
24022 -- No processing here. Processing was completed during parsing, since
24023 -- we need to have file names set as early as possible. Units are
24024 -- loaded well before semantic processing starts.
24026 -- The only processing we defer to this point is the check for
24027 -- correct placement.
24029 when Pragma_Source_File_Name_Project
=>
24031 Check_Valid_Configuration_Pragma
;
24033 -- Check that a pragma Source_File_Name_Project is used only in a
24034 -- configuration pragmas file.
24036 -- Pragmas Source_File_Name_Project should only be generated by
24037 -- the Project Manager in configuration pragmas files.
24039 -- This is really an ugly test. It seems to depend on some
24040 -- accidental and undocumented property. At the very least it
24041 -- needs to be documented, but it would be better to have a
24042 -- clean way of testing if we are in a configuration file???
24044 if Present
(Parent
(N
)) then
24046 ("pragma% can only appear in a configuration pragmas file");
24049 ----------------------
24050 -- Source_Reference --
24051 ----------------------
24053 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
24055 -- Nothing to do, all processing completed in Par.Prag, since we need
24056 -- the information for possible parser messages that are output.
24058 when Pragma_Source_Reference
=>
24065 -- pragma SPARK_Mode [(Auto | On | Off)];
24067 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
24068 Mode_Id
: SPARK_Mode_Type
;
24070 procedure Check_Pragma_Conformance
24071 (Context_Pragma
: Node_Id
;
24072 Entity
: Entity_Id
;
24073 Entity_Pragma
: Node_Id
);
24074 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
24075 -- conformance of pragma N depending the following scenarios:
24077 -- If pragma Context_Pragma is not Empty, verify that pragma N is
24078 -- compatible with the pragma Context_Pragma that was inherited
24079 -- from the context:
24080 -- * If the mode of Context_Pragma is ON, then the new mode can
24082 -- * If the mode of Context_Pragma is OFF, then the only allowed
24083 -- new mode is also OFF. Emit error if this is not the case.
24085 -- If Entity is not Empty, verify that pragma N is compatible with
24086 -- pragma Entity_Pragma that belongs to Entity.
24087 -- * If Entity_Pragma is Empty, always issue an error as this
24088 -- corresponds to the case where a previous section of Entity
24089 -- has no SPARK_Mode set.
24090 -- * If the mode of Entity_Pragma is ON, then the new mode can
24092 -- * If the mode of Entity_Pragma is OFF, then the only allowed
24093 -- new mode is also OFF. Emit error if this is not the case.
24095 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
24096 -- Subsidiary to routines Process_xxx. Verify that the related
24097 -- entity E subject to pragma SPARK_Mode is library-level.
24099 procedure Process_Body
(Decl
: Node_Id
);
24100 -- Verify the legality of pragma SPARK_Mode when it appears as the
24101 -- top of the body declarations of entry, package, protected unit,
24102 -- subprogram or task unit body denoted by Decl.
24104 procedure Process_Overloadable
(Decl
: Node_Id
);
24105 -- Verify the legality of pragma SPARK_Mode when it applies to an
24106 -- entry or [generic] subprogram declaration denoted by Decl.
24108 procedure Process_Private_Part
(Decl
: Node_Id
);
24109 -- Verify the legality of pragma SPARK_Mode when it appears at the
24110 -- top of the private declarations of a package spec, protected or
24111 -- task unit declaration denoted by Decl.
24113 procedure Process_Statement_Part
(Decl
: Node_Id
);
24114 -- Verify the legality of pragma SPARK_Mode when it appears at the
24115 -- top of the statement sequence of a package body denoted by node
24118 procedure Process_Visible_Part
(Decl
: Node_Id
);
24119 -- Verify the legality of pragma SPARK_Mode when it appears at the
24120 -- top of the visible declarations of a package spec, protected or
24121 -- task unit declaration denoted by Decl. The routine is also used
24122 -- on protected or task units declared without a definition.
24124 procedure Set_SPARK_Context
;
24125 -- Subsidiary to routines Process_xxx. Set the global variables
24126 -- which represent the mode of the context from pragma N. Ensure
24127 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
24129 ------------------------------
24130 -- Check_Pragma_Conformance --
24131 ------------------------------
24133 procedure Check_Pragma_Conformance
24134 (Context_Pragma
: Node_Id
;
24135 Entity
: Entity_Id
;
24136 Entity_Pragma
: Node_Id
)
24138 Err_Id
: Entity_Id
;
24142 -- The current pragma may appear without an argument. If this
24143 -- is the case, associate all error messages with the pragma
24146 if Present
(Arg1
) then
24152 -- The mode of the current pragma is compared against that of
24153 -- an enclosing context.
24155 if Present
(Context_Pragma
) then
24156 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
24158 -- Issue an error if the new mode is less restrictive than
24159 -- that of the context.
24161 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
24162 and then Get_SPARK_Mode_From_Annotation
(N
) = On
24165 ("cannot change SPARK_Mode from Off to On", Err_N
);
24166 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
24167 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
24172 -- The mode of the current pragma is compared against that of
24173 -- an initial package, protected type, subprogram or task type
24176 if Present
(Entity
) then
24178 -- A simple protected or task type is transformed into an
24179 -- anonymous type whose name cannot be used to issue error
24180 -- messages. Recover the original entity of the type.
24182 if Ekind
(Entity
) in E_Protected_Type | E_Task_Type
then
24185 (Original_Node
(Unit_Declaration_Node
(Entity
)));
24190 -- Both the initial declaration and the completion carry
24191 -- SPARK_Mode pragmas.
24193 if Present
(Entity_Pragma
) then
24194 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
24196 -- Issue an error if the new mode is less restrictive
24197 -- than that of the initial declaration.
24199 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
24200 and then Get_SPARK_Mode_From_Annotation
(N
) = On
24202 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
24203 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
24205 ("\value Off was set for SPARK_Mode on&#",
24210 -- Otherwise the initial declaration lacks a SPARK_Mode
24211 -- pragma in which case the current pragma is illegal as
24212 -- it cannot "complete".
24214 elsif Get_SPARK_Mode_From_Annotation
(N
) = Off
24215 and then (Is_Generic_Unit
(Entity
) or else In_Instance
)
24220 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
24221 Error_Msg_Sloc
:= Sloc
(Err_Id
);
24223 ("\no value was set for SPARK_Mode on&#",
24228 end Check_Pragma_Conformance
;
24230 --------------------------------
24231 -- Check_Library_Level_Entity --
24232 --------------------------------
24234 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
24235 procedure Add_Entity_To_Name_Buffer
;
24236 -- Add the E_Kind of entity E to the name buffer
24238 -------------------------------
24239 -- Add_Entity_To_Name_Buffer --
24240 -------------------------------
24242 procedure Add_Entity_To_Name_Buffer
is
24244 if Ekind
(E
) in E_Entry | E_Entry_Family
then
24245 Add_Str_To_Name_Buffer
("entry");
24247 elsif Ekind
(E
) in E_Generic_Package
24251 Add_Str_To_Name_Buffer
("package");
24253 elsif Ekind
(E
) in E_Protected_Body | E_Protected_Type
then
24254 Add_Str_To_Name_Buffer
("protected type");
24256 elsif Ekind
(E
) in E_Function
24257 | E_Generic_Function
24258 | E_Generic_Procedure
24260 | E_Subprogram_Body
24262 Add_Str_To_Name_Buffer
("subprogram");
24265 pragma Assert
(Ekind
(E
) in E_Task_Body | E_Task_Type
);
24266 Add_Str_To_Name_Buffer
("task type");
24268 end Add_Entity_To_Name_Buffer
;
24272 Msg_1
: constant String :=
24273 "incorrect placement of pragma% with value ""On"" '[[]']";
24276 -- Start of processing for Check_Library_Level_Entity
24279 -- A SPARK_Mode of On shall only apply to library-level
24280 -- entities, except for those in generic instances, which are
24281 -- ignored (even if the entity gets SPARK_Mode pragma attached
24282 -- in the AST, its effect is not taken into account unless the
24283 -- context already provides SPARK_Mode of On in GNATprove).
24285 if Get_SPARK_Mode_From_Annotation
(N
) = On
24286 and then not Is_Library_Level_Entity
(E
)
24287 and then Instantiation_Location
(Sloc
(N
)) = No_Location
24289 Error_Msg_Name_1
:= Pname
;
24290 Error_Msg_Code
:= GEC_SPARK_Mode_On_Not_Library_Level
;
24291 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
24294 Add_Str_To_Name_Buffer
("\& is not a library-level ");
24295 Add_Entity_To_Name_Buffer
;
24297 Msg_2
:= Name_Find
;
24298 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
24302 end Check_Library_Level_Entity
;
24308 procedure Process_Body
(Decl
: Node_Id
) is
24309 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24310 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
24313 -- Ignore pragma when applied to the special body created
24314 -- for inlining, recognized by its internal name _Parent; or
24315 -- when applied to the special body created for contracts,
24316 -- recognized by its internal name _Wrapped_Statements.
24318 if Chars
(Body_Id
) in Name_uParent
24319 | Name_uWrapped_Statements
24324 Check_Library_Level_Entity
(Body_Id
);
24326 -- For entry bodies, verify the legality against:
24327 -- * The mode of the context
24328 -- * The mode of the spec (if any)
24330 if Nkind
(Decl
) in N_Entry_Body | N_Subprogram_Body
then
24332 -- A stand-alone subprogram body
24334 if Body_Id
= Spec_Id
then
24335 Check_Pragma_Conformance
24336 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24338 Entity_Pragma
=> Empty
);
24340 -- An entry or subprogram body that completes a previous
24344 Check_Pragma_Conformance
24345 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24347 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
24351 Set_SPARK_Pragma
(Body_Id
, N
);
24352 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24354 -- For package bodies, verify the legality against:
24355 -- * The mode of the context
24356 -- * The mode of the private part
24358 -- This case is separated from protected and task bodies
24359 -- because the statement part of the package body inherits
24360 -- the mode of the body declarations.
24362 elsif Nkind
(Decl
) = N_Package_Body
then
24363 Check_Pragma_Conformance
24364 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24366 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
24369 Set_SPARK_Pragma
(Body_Id
, N
);
24370 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24371 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
24372 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
24374 -- For protected and task bodies, verify the legality against:
24375 -- * The mode of the context
24376 -- * The mode of the private part
24380 (Nkind
(Decl
) in N_Protected_Body | N_Task_Body
);
24382 Check_Pragma_Conformance
24383 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24385 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
24388 Set_SPARK_Pragma
(Body_Id
, N
);
24389 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24393 --------------------------
24394 -- Process_Overloadable --
24395 --------------------------
24397 procedure Process_Overloadable
(Decl
: Node_Id
) is
24398 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24399 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
24402 Check_Library_Level_Entity
(Spec_Id
);
24404 -- Verify the legality against:
24405 -- * The mode of the context
24407 Check_Pragma_Conformance
24408 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
24410 Entity_Pragma
=> Empty
);
24412 Set_SPARK_Pragma
(Spec_Id
, N
);
24413 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
24415 -- When the pragma applies to the anonymous object created for
24416 -- a single task type, decorate the type as well. This scenario
24417 -- arises when the single task type lacks a task definition,
24418 -- therefore there is no issue with respect to a potential
24419 -- pragma SPARK_Mode in the private part.
24421 -- task type Anon_Task_Typ;
24422 -- Obj : Anon_Task_Typ;
24423 -- pragma SPARK_Mode ...;
24425 if Is_Single_Task_Object
(Spec_Id
) then
24426 Set_SPARK_Pragma
(Spec_Typ
, N
);
24427 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
24428 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
24429 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
24431 end Process_Overloadable
;
24433 --------------------------
24434 -- Process_Private_Part --
24435 --------------------------
24437 procedure Process_Private_Part
(Decl
: Node_Id
) is
24438 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24441 Check_Library_Level_Entity
(Spec_Id
);
24443 -- Verify the legality against:
24444 -- * The mode of the visible declarations
24446 Check_Pragma_Conformance
24447 (Context_Pragma
=> Empty
,
24449 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
24452 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
24453 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
24454 end Process_Private_Part
;
24456 ----------------------------
24457 -- Process_Statement_Part --
24458 ----------------------------
24460 procedure Process_Statement_Part
(Decl
: Node_Id
) is
24461 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24464 Check_Library_Level_Entity
(Body_Id
);
24466 -- Verify the legality against:
24467 -- * The mode of the body declarations
24469 Check_Pragma_Conformance
24470 (Context_Pragma
=> Empty
,
24472 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
24475 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
24476 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
24477 end Process_Statement_Part
;
24479 --------------------------
24480 -- Process_Visible_Part --
24481 --------------------------
24483 procedure Process_Visible_Part
(Decl
: Node_Id
) is
24484 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24485 Obj_Id
: Entity_Id
;
24488 Check_Library_Level_Entity
(Spec_Id
);
24490 -- Verify the legality against:
24491 -- * The mode of the context
24493 Check_Pragma_Conformance
24494 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
24496 Entity_Pragma
=> Empty
);
24498 -- A task unit declared without a definition does not set the
24499 -- SPARK_Mode of the context because the task does not have any
24500 -- entries that could inherit the mode.
24502 if Nkind
(Decl
) not in
24503 N_Single_Task_Declaration | N_Task_Type_Declaration
24508 Set_SPARK_Pragma
(Spec_Id
, N
);
24509 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
24510 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
24511 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
24513 -- When the pragma applies to a single protected or task type,
24514 -- decorate the corresponding anonymous object as well.
24516 -- protected Anon_Prot_Typ is
24517 -- pragma SPARK_Mode ...;
24519 -- end Anon_Prot_Typ;
24521 -- Obj : Anon_Prot_Typ;
24523 if Is_Single_Concurrent_Type
(Spec_Id
) then
24524 Obj_Id
:= Anonymous_Object
(Spec_Id
);
24526 Set_SPARK_Pragma
(Obj_Id
, N
);
24527 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
24529 end Process_Visible_Part
;
24531 -----------------------
24532 -- Set_SPARK_Context --
24533 -----------------------
24535 procedure Set_SPARK_Context
is
24537 SPARK_Mode
:= Mode_Id
;
24538 SPARK_Mode_Pragma
:= N
;
24539 end Set_SPARK_Context
;
24547 -- Start of processing for Do_SPARK_Mode
24551 Check_No_Identifiers
;
24552 Check_At_Most_N_Arguments
(1);
24554 -- Check the legality of the mode (no argument = ON)
24556 if Arg_Count
= 1 then
24557 Check_Arg_Is_One_Of
(Arg1
, Name_Auto
, Name_On
, Name_Off
);
24558 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
24563 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
24564 Context
:= Parent
(N
);
24566 -- When a SPARK_Mode pragma appears inside an instantiation whose
24567 -- enclosing context has SPARK_Mode set to "off", the pragma has
24568 -- no semantic effect.
24570 if Ignore_SPARK_Mode_Pragmas_In_Instance
24571 and then Mode_Id
/= Off
24573 Rewrite
(N
, Make_Null_Statement
(Loc
));
24578 -- The pragma appears in a configuration file
24580 if No
(Context
) then
24581 Check_Valid_Configuration_Pragma
;
24583 if Present
(SPARK_Mode_Pragma
) then
24586 Prev
=> SPARK_Mode_Pragma
);
24592 -- The pragma acts as a configuration pragma in a compilation unit
24594 -- pragma SPARK_Mode ...;
24595 -- package Pack is ...;
24597 elsif Nkind
(Context
) = N_Compilation_Unit
24598 and then List_Containing
(N
) = Context_Items
(Context
)
24600 Check_Valid_Configuration_Pragma
;
24603 -- Otherwise the placement of the pragma within the tree dictates
24604 -- its associated construct. Inspect the declarative list where
24605 -- the pragma resides to find a potential construct.
24608 -- An explicit mode of Auto is only allowed as a configuration
24609 -- pragma. Escape "pragma" to avoid replacement with "aspect".
24611 if Mode_Id
= None
then
24613 ("only configuration 'p'r'a'g'm'a% can have value &",
24618 while Present
(Stmt
) loop
24620 -- Skip prior pragmas, but check for duplicates. Note that
24621 -- this also takes care of pragmas generated for aspects.
24623 if Nkind
(Stmt
) = N_Pragma
then
24624 if Pragma_Name
(Stmt
) = Pname
then
24631 -- The pragma applies to an expression function that has
24632 -- already been rewritten into a subprogram declaration.
24634 -- function Expr_Func return ... is (...);
24635 -- pragma SPARK_Mode ...;
24637 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
24638 and then Nkind
(Original_Node
(Stmt
)) =
24639 N_Expression_Function
24641 Process_Overloadable
(Stmt
);
24644 -- The pragma applies to the anonymous object created for a
24645 -- single concurrent type.
24647 -- protected type Anon_Prot_Typ ...;
24648 -- Obj : Anon_Prot_Typ;
24649 -- pragma SPARK_Mode ...;
24651 elsif Nkind
(Stmt
) = N_Object_Declaration
24652 and then Is_Single_Concurrent_Object
24653 (Defining_Entity
(Stmt
))
24655 Process_Overloadable
(Stmt
);
24658 -- Skip internally generated code
24660 elsif not Comes_From_Source
(Stmt
) then
24663 -- The pragma applies to an entry or [generic] subprogram
24667 -- pragma SPARK_Mode ...;
24670 -- procedure Proc ...;
24671 -- pragma SPARK_Mode ...;
24673 elsif Nkind
(Stmt
) in N_Generic_Subprogram_Declaration
24674 | N_Subprogram_Declaration
24675 or else (Nkind
(Stmt
) = N_Entry_Declaration
24676 and then Is_Protected_Type
24677 (Scope
(Defining_Entity
(Stmt
))))
24679 Process_Overloadable
(Stmt
);
24682 -- Otherwise the pragma does not apply to a legal construct
24683 -- or it does not appear at the top of a declarative or a
24684 -- statement list. Issue an error and stop the analysis.
24693 -- The pragma applies to a package or a subprogram that acts as
24694 -- a compilation unit.
24696 -- procedure Proc ...;
24697 -- pragma SPARK_Mode ...;
24699 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
24700 Context
:= Unit
(Parent
(Context
));
24703 -- The pragma appears at the top of entry, package, protected
24704 -- unit, subprogram or task unit body declarations.
24706 -- entry Ent when ... is
24707 -- pragma SPARK_Mode ...;
24709 -- package body Pack is
24710 -- pragma SPARK_Mode ...;
24712 -- procedure Proc ... is
24713 -- pragma SPARK_Mode;
24715 -- protected body Prot is
24716 -- pragma SPARK_Mode ...;
24718 if Nkind
(Context
) in N_Entry_Body
24721 | N_Subprogram_Body
24724 Process_Body
(Context
);
24726 -- The pragma appears at the top of the visible or private
24727 -- declaration of a package spec, protected or task unit.
24730 -- pragma SPARK_Mode ...;
24732 -- pragma SPARK_Mode ...;
24734 -- protected [type] Prot is
24735 -- pragma SPARK_Mode ...;
24737 -- pragma SPARK_Mode ...;
24739 elsif Nkind
(Context
) in N_Package_Specification
24740 | N_Protected_Definition
24741 | N_Task_Definition
24743 if List_Containing
(N
) = Visible_Declarations
(Context
) then
24744 Process_Visible_Part
(Parent
(Context
));
24746 Process_Private_Part
(Parent
(Context
));
24749 -- The pragma appears at the top of package body statements
24751 -- package body Pack is
24753 -- pragma SPARK_Mode;
24755 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
24756 and then Nkind
(Parent
(Context
)) = N_Package_Body
24758 Process_Statement_Part
(Parent
(Context
));
24760 -- The pragma appeared as an aspect of a [generic] subprogram
24761 -- declaration that acts as a compilation unit.
24764 -- procedure Proc ...;
24765 -- pragma SPARK_Mode ...;
24767 elsif Nkind
(Context
) in N_Generic_Subprogram_Declaration
24768 | N_Subprogram_Declaration
24770 Process_Overloadable
(Context
);
24772 -- The pragma does not apply to a legal construct, issue error
24780 --------------------------------
24781 -- Static_Elaboration_Desired --
24782 --------------------------------
24784 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
24786 when Pragma_Static_Elaboration_Desired
=>
24788 Check_At_Most_N_Arguments
(1);
24790 if Is_Compilation_Unit
(Current_Scope
)
24791 and then Ekind
(Current_Scope
) = E_Package
24793 Set_Static_Elaboration_Desired
(Current_Scope
, True);
24795 Error_Pragma
("pragma% must apply to a library-level package");
24802 -- pragma Storage_Size (EXPRESSION);
24804 when Pragma_Storage_Size
=> Storage_Size
: declare
24805 P
: constant Node_Id
:= Parent
(N
);
24809 Check_No_Identifiers
;
24810 Check_Arg_Count
(1);
24812 -- The expression must be analyzed in the special manner described
24813 -- in "Handling of Default Expressions" in sem.ads.
24815 Arg
:= Get_Pragma_Arg
(Arg1
);
24816 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
24818 if not Is_OK_Static_Expression
(Arg
) then
24819 Check_Restriction
(Static_Storage_Size
, Arg
);
24822 if Nkind
(P
) /= N_Task_Definition
then
24826 if Has_Storage_Size_Pragma
(P
) then
24827 Error_Pragma
("duplicate pragma% not allowed");
24829 Set_Has_Storage_Size_Pragma
(P
, True);
24832 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
24840 -- pragma Storage_Unit (NUMERIC_LITERAL);
24842 -- Only permitted argument is System'Storage_Unit value
24844 when Pragma_Storage_Unit
=>
24845 Check_No_Identifiers
;
24846 Check_Arg_Count
(1);
24847 Check_Arg_Is_Integer_Literal
(Arg1
);
24849 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
24850 UI_From_Int
(Ttypes
.System_Storage_Unit
)
24852 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
24854 ("the only allowed argument for pragma% is ^", Arg1
);
24857 --------------------
24858 -- Stream_Convert --
24859 --------------------
24861 -- pragma Stream_Convert (
24862 -- [Entity =>] type_LOCAL_NAME,
24863 -- [Read =>] function_NAME,
24864 -- [Write =>] function NAME);
24866 when Pragma_Stream_Convert
=> Stream_Convert
: declare
24867 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
24868 -- Check that the given argument is the name of a local function
24869 -- of one argument that is not overloaded earlier in the current
24870 -- local scope. A check is also made that the argument is a
24871 -- function with one parameter.
24873 --------------------------------------
24874 -- Check_OK_Stream_Convert_Function --
24875 --------------------------------------
24877 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
24881 Check_Arg_Is_Local_Name
(Arg
);
24882 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
24884 if Has_Homonym
(Ent
) then
24886 ("argument for pragma% may not be overloaded", Arg
);
24889 if Ekind
(Ent
) /= E_Function
24890 or else No
(First_Formal
(Ent
))
24891 or else Present
(Next_Formal
(First_Formal
(Ent
)))
24894 ("argument for pragma% must be function of one argument",
24896 elsif Is_Abstract_Subprogram
(Ent
) then
24898 ("argument for pragma% cannot be abstract", Arg
);
24900 end Check_OK_Stream_Convert_Function
;
24902 -- Start of processing for Stream_Convert
24906 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
24907 Check_Arg_Count
(3);
24908 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24909 Check_Optional_Identifier
(Arg2
, Name_Read
);
24910 Check_Optional_Identifier
(Arg3
, Name_Write
);
24911 Check_Arg_Is_Local_Name
(Arg1
);
24912 Check_OK_Stream_Convert_Function
(Arg2
);
24913 Check_OK_Stream_Convert_Function
(Arg3
);
24916 Typ
: constant Entity_Id
:=
24917 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
24918 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
24919 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
24922 Check_First_Subtype
(Arg1
);
24924 -- Check for too early or too late. Note that we don't enforce
24925 -- the rule about primitive operations in this case, since, as
24926 -- is the case for explicit stream attributes themselves, these
24927 -- restrictions are not appropriate. Note that the chaining of
24928 -- the pragma by Rep_Item_Too_Late is actually the critical
24929 -- processing done for this pragma.
24931 if Rep_Item_Too_Early
(Typ
, N
)
24933 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
24938 -- Return if previous error
24940 if Etype
(Typ
) = Any_Type
24942 Etype
(Read
) = Any_Type
24944 Etype
(Write
) = Any_Type
24951 if Underlying_Type
(Etype
(Read
)) /= Typ
then
24953 ("incorrect return type for function&", Arg2
);
24956 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
24958 ("incorrect parameter type for function&", Arg3
);
24961 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
24962 Underlying_Type
(Etype
(Write
))
24965 ("result type of & does not match Read parameter type",
24969 end Stream_Convert
;
24975 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24977 -- This is processed by the parser since some of the style checks
24978 -- take place during source scanning and parsing. This means that
24979 -- we don't need to issue error messages here.
24981 when Pragma_Style_Checks
=> Style_Checks
: declare
24982 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
24988 Check_No_Identifiers
;
24990 -- Two argument form
24992 if Arg_Count
= 2 then
24993 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
25000 E_Id
:= Get_Pragma_Arg
(Arg2
);
25003 if not Is_Entity_Name
(E_Id
) then
25005 ("second argument of pragma% must be entity name",
25009 E
:= Entity
(E_Id
);
25011 if not Ignore_Style_Checks_Pragmas
then
25016 Set_Suppress_Style_Checks
25017 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
25018 exit when No
(Homonym
(E
));
25025 -- One argument form
25028 Check_Arg_Count
(1);
25030 if Ignore_Style_Checks_Pragmas
then
25034 if Nkind
(A
) = N_String_Literal
then
25038 Slen
: constant Natural := Natural (String_Length
(S
));
25039 Options
: String (1 .. Slen
);
25045 C
:= Get_String_Char
(S
, Pos
(J
));
25046 exit when not In_Character_Range
(C
);
25047 Options
(J
) := Get_Character
(C
);
25049 -- If at end of string, set options. As per discussion
25050 -- above, no need to check for errors, since we issued
25051 -- them in the parser.
25054 Set_Style_Check_Options
(Options
);
25063 elsif Nkind
(A
) = N_Identifier
then
25064 if Chars
(A
) = Name_All_Checks
then
25066 Set_GNAT_Style_Check_Options
;
25068 Set_Default_Style_Check_Options
;
25071 elsif Chars
(A
) = Name_On
then
25072 Style_Check
:= True;
25074 elsif Chars
(A
) = Name_Off
then
25075 Style_Check
:= False;
25081 ------------------------
25082 -- Subprogram_Variant --
25083 ------------------------
25085 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_LIST );
25087 -- SUBPROGRAM_VARIANT_LIST ::= STRUCTURAL_SUBPROGRAM_VARIANT_ITEM
25088 -- | NUMERIC_SUBPROGRAM_VARIANT_ITEMS
25089 -- NUMERIC_SUBPROGRAM_VARIANT_ITEMS ::=
25090 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM
25091 -- {, NUMERIC_SUBPROGRAM_VARIANT_ITEM}
25092 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM ::= CHANGE_DIRECTION => EXPRESSION
25093 -- STRUCTURAL_SUBPROGRAM_VARIANT_ITEM ::= Structural => EXPRESSION
25094 -- CHANGE_DIRECTION ::= Increases | Decreases
25096 -- Characteristics:
25098 -- * Analysis - The annotation undergoes initial checks to verify
25099 -- the legal placement and context. Secondary checks preanalyze the
25102 -- Analyze_Subprogram_Variant_In_Decl_Part
25104 -- * Expansion - The annotation is expanded during the expansion of
25105 -- the related subprogram [body] contract as performed in:
25107 -- Expand_Subprogram_Contract
25109 -- * Template - The annotation utilizes the generic template of the
25110 -- related subprogram [body] when it is:
25112 -- aspect on subprogram declaration
25113 -- aspect on stand-alone subprogram body
25114 -- pragma on stand-alone subprogram body
25116 -- The annotation must prepare its own template when it is:
25118 -- pragma on subprogram declaration
25120 -- * Globals - Capture of global references must occur after full
25123 -- * Instance - The annotation is instantiated automatically when
25124 -- the related generic subprogram [body] is instantiated except for
25125 -- the "pragma on subprogram declaration" case. In that scenario
25126 -- the annotation must instantiate itself.
25128 when Pragma_Subprogram_Variant
=> Subprogram_Variant
: declare
25129 Spec_Id
: Entity_Id
;
25130 Subp_Decl
: Node_Id
;
25131 Subp_Spec
: Node_Id
;
25135 Check_No_Identifiers
;
25136 Check_Arg_Count
(1);
25138 -- Ensure the proper placement of the pragma. Subprogram_Variant
25139 -- must be associated with a subprogram declaration or a body that
25143 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25145 -- Generic subprogram
25147 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25150 -- Body acts as spec
25152 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25153 and then No
(Corresponding_Spec
(Subp_Decl
))
25157 -- Body stub acts as spec
25159 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25160 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25166 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25167 Subp_Spec
:= Specification
(Subp_Decl
);
25169 -- Pragma Subprogram_Variant is forbidden on null procedures,
25170 -- as this may lead to potential ambiguities in behavior when
25171 -- interface null procedures are involved. Also, it just
25172 -- wouldn't make sense, because null procedure is not
25175 if Nkind
(Subp_Spec
) = N_Procedure_Specification
25176 and then Null_Present
(Subp_Spec
)
25178 Error_Msg_N
(Fix_Error
25179 ("pragma % cannot apply to null procedure"), N
);
25187 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25189 -- A pragma that applies to a Ghost entity becomes Ghost for the
25190 -- purposes of legality checks and removal of ignored Ghost code.
25192 Mark_Ghost_Pragma
(N
, Spec_Id
);
25193 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
25195 -- Chain the pragma on the contract for further processing by
25196 -- Analyze_Subprogram_Variant_In_Decl_Part.
25198 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
25200 -- Fully analyze the pragma when it appears inside a subprogram
25201 -- body because it cannot benefit from forward references.
25203 if Nkind
(Subp_Decl
) in N_Subprogram_Body
25204 | N_Subprogram_Body_Stub
25206 -- The legality checks of pragma Subprogram_Variant are
25207 -- affected by the SPARK mode in effect and the volatility
25208 -- of the context. Analyze all pragmas in a specific order.
25210 Analyze_If_Present
(Pragma_SPARK_Mode
);
25211 Analyze_If_Present
(Pragma_Volatile_Function
);
25212 Analyze_Subprogram_Variant_In_Decl_Part
(N
);
25214 end Subprogram_Variant
;
25220 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
25222 when Pragma_Subtitle
=>
25224 Check_Arg_Count
(1);
25225 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
25226 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
25233 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
25235 when Pragma_Suppress
=>
25236 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
25242 -- pragma Suppress_All;
25244 -- The only check made here is that the pragma has no arguments.
25245 -- There are no placement rules, and the processing required (setting
25246 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
25247 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
25248 -- then creates and inserts a pragma Suppress (All_Checks).
25250 when Pragma_Suppress_All
=>
25252 Check_Arg_Count
(0);
25254 -------------------------
25255 -- Suppress_Debug_Info --
25256 -------------------------
25258 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
25260 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
25261 Nam_Id
: Entity_Id
;
25265 Check_Arg_Count
(1);
25266 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25267 Check_Arg_Is_Local_Name
(Arg1
);
25269 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
25271 -- A pragma that applies to a Ghost entity becomes Ghost for the
25272 -- purposes of legality checks and removal of ignored Ghost code.
25274 Mark_Ghost_Pragma
(N
, Nam_Id
);
25275 Set_Debug_Info_Off
(Nam_Id
);
25276 end Suppress_Debug_Info
;
25278 ----------------------------------
25279 -- Suppress_Exception_Locations --
25280 ----------------------------------
25282 -- pragma Suppress_Exception_Locations;
25284 when Pragma_Suppress_Exception_Locations
=>
25286 Check_Arg_Count
(0);
25287 Check_Valid_Configuration_Pragma
;
25288 Exception_Locations_Suppressed
:= True;
25290 -----------------------------
25291 -- Suppress_Initialization --
25292 -----------------------------
25294 -- pragma Suppress_Initialization ([Entity =>] type_Name);
25296 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
25302 Check_Arg_Count
(1);
25303 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25304 Check_Arg_Is_Local_Name
(Arg1
);
25306 E_Id
:= Get_Pragma_Arg
(Arg1
);
25308 if Etype
(E_Id
) = Any_Type
then
25312 E
:= Entity
(E_Id
);
25314 -- A pragma that applies to a Ghost entity becomes Ghost for the
25315 -- purposes of legality checks and removal of ignored Ghost code.
25317 Mark_Ghost_Pragma
(N
, E
);
25319 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
25321 ("pragma% requires variable, type or subtype", Arg1
);
25324 if Rep_Item_Too_Early
(E
, N
)
25326 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
25331 -- For incomplete/private type, set flag on full view
25333 if Is_Incomplete_Or_Private_Type
(E
) then
25334 if No
(Full_View
(Base_Type
(E
))) then
25336 ("argument of pragma% cannot be an incomplete type", Arg1
);
25338 Set_Suppress_Initialization
(Full_View
(E
));
25341 -- For first subtype, set flag on base type
25343 elsif Is_First_Subtype
(E
) then
25344 Set_Suppress_Initialization
(Base_Type
(E
));
25346 -- For other than first subtype, set flag on subtype or variable
25349 Set_Suppress_Initialization
(E
);
25357 -- pragma System_Name (DIRECT_NAME);
25359 -- Syntax check: one argument, which must be the identifier GNAT or
25360 -- the identifier GCC, no other identifiers are acceptable.
25362 when Pragma_System_Name
=>
25364 Check_No_Identifiers
;
25365 Check_Arg_Count
(1);
25366 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
25368 -----------------------------
25369 -- Task_Dispatching_Policy --
25370 -----------------------------
25372 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
25374 when Pragma_Task_Dispatching_Policy
=> declare
25378 Check_Ada_83_Warning
;
25379 Check_Arg_Count
(1);
25380 Check_No_Identifiers
;
25381 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
25382 Check_Valid_Configuration_Pragma
;
25383 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
25384 DP
:= Fold_Upper
(Name_Buffer
(1));
25386 if Task_Dispatching_Policy
/= ' '
25387 and then Task_Dispatching_Policy
/= DP
25389 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
25391 ("task dispatching policy incompatible with policy#");
25393 -- Set new policy, but always preserve System_Location since we
25394 -- like the error message with the run time name.
25397 Task_Dispatching_Policy
:= DP
;
25399 if Task_Dispatching_Policy_Sloc
/= System_Location
then
25400 Task_Dispatching_Policy_Sloc
:= Loc
;
25409 -- pragma Task_Info (EXPRESSION);
25411 when Pragma_Task_Info
=> Task_Info
: declare
25412 P
: constant Node_Id
:= Parent
(N
);
25418 if Warn_On_Obsolescent_Feature
then
25420 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
25421 & "instead?j?", N
);
25424 if Nkind
(P
) /= N_Task_Definition
then
25425 Error_Pragma
("pragma% must appear in task definition");
25428 Check_No_Identifiers
;
25429 Check_Arg_Count
(1);
25431 Analyze_And_Resolve
25432 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
25434 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
25438 Ent
:= Defining_Identifier
(Parent
(P
));
25440 -- Check duplicate pragma before we chain the pragma in the Rep
25441 -- Item chain of Ent.
25444 (Ent
, Name_Task_Info
, Check_Parents
=> False)
25446 Error_Pragma
("duplicate pragma% not allowed");
25449 Record_Rep_Item
(Ent
, N
);
25456 -- pragma Task_Name (string_EXPRESSION);
25458 when Pragma_Task_Name
=> Task_Name
: declare
25459 P
: constant Node_Id
:= Parent
(N
);
25464 Check_No_Identifiers
;
25465 Check_Arg_Count
(1);
25467 Arg
:= Get_Pragma_Arg
(Arg1
);
25469 -- The expression is used in the call to Create_Task, and must be
25470 -- expanded there, not in the context of the current spec. It must
25471 -- however be analyzed to capture global references, in case it
25472 -- appears in a generic context.
25474 Preanalyze_And_Resolve
(Arg
, Standard_String
);
25476 if Nkind
(P
) /= N_Task_Definition
then
25480 Ent
:= Defining_Identifier
(Parent
(P
));
25482 -- Check duplicate pragma before we chain the pragma in the Rep
25483 -- Item chain of Ent.
25486 (Ent
, Name_Task_Name
, Check_Parents
=> False)
25488 Error_Pragma
("duplicate pragma% not allowed");
25491 Record_Rep_Item
(Ent
, N
);
25498 -- pragma Task_Storage (
25499 -- [Task_Type =>] LOCAL_NAME,
25500 -- [Top_Guard =>] static_integer_EXPRESSION);
25502 when Pragma_Task_Storage
=> Task_Storage
: declare
25503 Args
: Args_List
(1 .. 2);
25504 Names
: constant Name_List
(1 .. 2) := (
25508 Task_Type
: Node_Id
renames Args
(1);
25509 Top_Guard
: Node_Id
renames Args
(2);
25515 Gather_Associations
(Names
, Args
);
25517 if No
(Task_Type
) then
25519 ("missing task_type argument for pragma%");
25522 Check_Arg_Is_Local_Name
(Task_Type
);
25524 Ent
:= Entity
(Task_Type
);
25526 if not Is_Task_Type
(Ent
) then
25528 ("argument for pragma% must be task type", Task_Type
);
25531 if No
(Top_Guard
) then
25533 ("pragma% takes two arguments", Task_Type
);
25535 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
25538 Check_First_Subtype
(Task_Type
);
25540 if Rep_Item_Too_Late
(Ent
, N
) then
25549 -- pragma Test_Case
25550 -- ([Name =>] Static_String_EXPRESSION
25551 -- ,[Mode =>] MODE_TYPE
25552 -- [, Requires => Boolean_EXPRESSION]
25553 -- [, Ensures => Boolean_EXPRESSION]);
25555 -- MODE_TYPE ::= Nominal | Robustness
25557 -- Characteristics:
25559 -- * Analysis - The annotation undergoes initial checks to verify
25560 -- the legal placement and context. Secondary checks preanalyze the
25563 -- Analyze_Test_Case_In_Decl_Part
25565 -- * Expansion - None.
25567 -- * Template - The annotation utilizes the generic template of the
25568 -- related subprogram when it is:
25570 -- aspect on subprogram declaration
25572 -- The annotation must prepare its own template when it is:
25574 -- pragma on subprogram declaration
25576 -- * Globals - Capture of global references must occur after full
25579 -- * Instance - The annotation is instantiated automatically when
25580 -- the related generic subprogram is instantiated except for the
25581 -- "pragma on subprogram declaration" case. In that scenario the
25582 -- annotation must instantiate itself.
25584 when Pragma_Test_Case
=> Test_Case
: declare
25585 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
25586 -- Ensure that the contract of subprogram Subp_Id does not contain
25587 -- another Test_Case pragma with the same Name as the current one.
25589 -------------------------
25590 -- Check_Distinct_Name --
25591 -------------------------
25593 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
25594 Items
: constant Node_Id
:= Contract
(Subp_Id
);
25595 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
25599 -- Inspect all Test_Case pragma of the related subprogram
25600 -- looking for one with a duplicate "Name" argument.
25602 if Present
(Items
) then
25603 Prag
:= Contract_Test_Cases
(Items
);
25604 while Present
(Prag
) loop
25605 if Pragma_Name
(Prag
) = Name_Test_Case
25607 and then String_Equal
25608 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
25610 Error_Msg_Sloc
:= Sloc
(Prag
);
25611 Error_Pragma
("name for pragma % is already used #");
25614 Prag
:= Next_Pragma
(Prag
);
25617 end Check_Distinct_Name
;
25621 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
25624 Subp_Decl
: Node_Id
;
25625 Subp_Id
: Entity_Id
;
25627 -- Start of processing for Test_Case
25631 Check_At_Least_N_Arguments
(2);
25632 Check_At_Most_N_Arguments
(4);
25634 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
25638 Check_Optional_Identifier
(Arg1
, Name_Name
);
25639 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
25643 Check_Optional_Identifier
(Arg2
, Name_Mode
);
25644 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
25646 -- Arguments "Requires" and "Ensures"
25648 if Present
(Arg3
) then
25649 if Present
(Arg4
) then
25650 Check_Identifier
(Arg3
, Name_Requires
);
25651 Check_Identifier
(Arg4
, Name_Ensures
);
25653 Check_Identifier_Is_One_Of
25654 (Arg3
, Name_Requires
, Name_Ensures
);
25658 -- Pragma Test_Case must be associated with a subprogram declared
25659 -- in a library-level package. First determine whether the current
25660 -- compilation unit is a legal context.
25662 if Nkind
(Pack_Decl
) in N_Package_Declaration
25663 | N_Generic_Package_Declaration
25667 -- Otherwise the placement is illegal
25671 ("pragma % must be specified within a package declaration");
25674 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
25676 -- Find the enclosing context
25678 Context
:= Parent
(Subp_Decl
);
25680 if Present
(Context
) then
25681 Context
:= Parent
(Context
);
25684 -- Verify the placement of the pragma
25686 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
25688 ("pragma % cannot be applied to abstract subprogram");
25690 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
25691 Error_Pragma
("pragma % cannot be applied to entry");
25693 -- The context is a [generic] subprogram declared at the top level
25694 -- of the [generic] package unit.
25696 elsif Nkind
(Subp_Decl
) in N_Generic_Subprogram_Declaration
25697 | N_Subprogram_Declaration
25698 and then Present
(Context
)
25699 and then Nkind
(Context
) in N_Generic_Package_Declaration
25700 | N_Package_Declaration
25704 -- Otherwise the placement is illegal
25708 ("pragma % must be applied to a library-level subprogram "
25712 Subp_Id
:= Defining_Entity
(Subp_Decl
);
25714 -- A pragma that applies to a Ghost entity becomes Ghost for the
25715 -- purposes of legality checks and removal of ignored Ghost code.
25717 Mark_Ghost_Pragma
(N
, Subp_Id
);
25719 -- Chain the pragma on the contract for further processing by
25720 -- Analyze_Test_Case_In_Decl_Part.
25722 Add_Contract_Item
(N
, Subp_Id
);
25724 -- Preanalyze the original aspect argument "Name" for a generic
25725 -- subprogram to properly capture global references.
25727 if Is_Generic_Subprogram
(Subp_Id
) then
25728 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
25730 if Present
(Asp_Arg
) then
25732 -- The argument appears with an identifier in association
25735 if Nkind
(Asp_Arg
) = N_Component_Association
then
25736 Asp_Arg
:= Expression
(Asp_Arg
);
25739 Check_Expr_Is_OK_Static_Expression
25740 (Asp_Arg
, Standard_String
);
25744 -- Ensure that the all Test_Case pragmas of the related subprogram
25745 -- have distinct names.
25747 Check_Distinct_Name
(Subp_Id
);
25749 -- Fully analyze the pragma when it appears inside an entry
25750 -- or subprogram body because it cannot benefit from forward
25753 if Nkind
(Subp_Decl
) in N_Entry_Body
25754 | N_Subprogram_Body
25755 | N_Subprogram_Body_Stub
25757 -- The legality checks of pragma Test_Case are affected by the
25758 -- SPARK mode in effect and the volatility of the context.
25759 -- Analyze all pragmas in a specific order.
25761 Analyze_If_Present
(Pragma_SPARK_Mode
);
25762 Analyze_If_Present
(Pragma_Volatile_Function
);
25763 Analyze_Test_Case_In_Decl_Part
(N
);
25767 --------------------------
25768 -- Thread_Local_Storage --
25769 --------------------------
25771 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
25773 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
25779 Check_Arg_Count
(1);
25780 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25781 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
25783 Id
:= Get_Pragma_Arg
(Arg1
);
25785 if not Is_Entity_Name
(Id
)
25786 or else Ekind
(Entity
(Id
)) /= E_Variable
25788 Error_Pragma_Arg
("local variable name required", Arg1
);
25793 -- A pragma that applies to a Ghost entity becomes Ghost for the
25794 -- purposes of legality checks and removal of ignored Ghost code.
25796 Mark_Ghost_Pragma
(N
, E
);
25798 if Rep_Item_Too_Early
(E
, N
)
25800 Rep_Item_Too_Late
(E
, N
)
25805 Set_Has_Pragma_Thread_Local_Storage
(E
);
25806 Set_Has_Gigi_Rep_Item
(E
);
25807 end Thread_Local_Storage
;
25813 -- pragma Time_Slice (static_duration_EXPRESSION);
25815 when Pragma_Time_Slice
=> Time_Slice
: declare
25821 Check_Arg_Count
(1);
25822 Check_No_Identifiers
;
25823 Check_In_Main_Program
;
25824 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
25826 if not Error_Posted
(Arg1
) then
25828 while Present
(Nod
) loop
25829 if Nkind
(Nod
) = N_Pragma
25830 and then Pragma_Name
(Nod
) = Name_Time_Slice
25832 Error_Msg_Name_1
:= Pname
;
25833 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
25840 -- Process only if in main unit
25842 if Get_Source_Unit
(Loc
) = Main_Unit
then
25843 Opt
.Time_Slice_Set
:= True;
25844 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
25846 if Val
<= Ureal_0
then
25847 Opt
.Time_Slice_Value
:= 0;
25849 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
25850 Opt
.Time_Slice_Value
:= 1_000_000_000
;
25853 Opt
.Time_Slice_Value
:=
25854 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
25863 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
25865 -- TITLING_OPTION ::=
25866 -- [Title =>] STRING_LITERAL
25867 -- | [Subtitle =>] STRING_LITERAL
25869 when Pragma_Title
=> Title
: declare
25870 Args
: Args_List
(1 .. 2);
25871 Names
: constant Name_List
(1 .. 2) := (
25877 Gather_Associations
(Names
, Args
);
25880 for J
in 1 .. 2 loop
25881 if Present
(Args
(J
)) then
25882 Check_Arg_Is_OK_Static_Expression
25883 (Args
(J
), Standard_String
);
25888 ----------------------------
25889 -- Type_Invariant[_Class] --
25890 ----------------------------
25892 -- pragma Type_Invariant[_Class]
25893 -- ([Entity =>] type_LOCAL_NAME,
25894 -- [Check =>] EXPRESSION);
25896 when Pragma_Type_Invariant
25897 | Pragma_Type_Invariant_Class
25899 Type_Invariant
: declare
25900 I_Pragma
: Node_Id
;
25903 Check_Arg_Count
(2);
25905 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
25906 -- setting Class_Present for the Type_Invariant_Class case.
25908 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
25909 I_Pragma
:= New_Copy
(N
);
25910 Set_Pragma_Identifier
25911 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
25912 Rewrite
(N
, I_Pragma
);
25913 Set_Analyzed
(N
, False);
25915 end Type_Invariant
;
25917 ---------------------
25918 -- Unchecked_Union --
25919 ---------------------
25921 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
25923 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
25924 Assoc
: constant Node_Id
:= Arg1
;
25925 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
25935 Check_No_Identifiers
;
25936 Check_Arg_Count
(1);
25937 Check_Arg_Is_Local_Name
(Arg1
);
25939 Find_Type
(Type_Id
);
25941 Typ
:= Entity
(Type_Id
);
25943 -- A pragma that applies to a Ghost entity becomes Ghost for the
25944 -- purposes of legality checks and removal of ignored Ghost code.
25946 Mark_Ghost_Pragma
(N
, Typ
);
25949 or else Rep_Item_Too_Early
(Typ
, N
)
25953 Typ
:= Underlying_Type
(Typ
);
25956 if Rep_Item_Too_Late
(Typ
, N
) then
25960 Check_First_Subtype
(Arg1
);
25962 -- Note remaining cases are references to a type in the current
25963 -- declarative part. If we find an error, we post the error on
25964 -- the relevant type declaration at an appropriate point.
25966 if not Is_Record_Type
(Typ
) then
25967 Error_Msg_N
("unchecked union must be record type", Typ
);
25970 elsif Is_Tagged_Type
(Typ
) then
25971 Error_Msg_N
("unchecked union must not be tagged", Typ
);
25974 elsif not Has_Discriminants
(Typ
) then
25976 ("unchecked union must have one discriminant", Typ
);
25979 -- Note: in previous versions of GNAT we used to check for limited
25980 -- types and give an error, but in fact the standard does allow
25981 -- Unchecked_Union on limited types, so this check was removed.
25983 -- Similarly, GNAT used to require that all discriminants have
25984 -- default values, but this is not mandated by the RM.
25986 -- Proceed with basic error checks completed
25989 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
25990 Clist
:= Component_List
(Tdef
);
25992 -- Check presence of component list and variant part
25994 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
25996 ("unchecked union must have variant part", Tdef
);
26000 -- Check components
26002 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
26003 while Present
(Comp
) loop
26004 Check_Component
(Comp
, Typ
);
26005 Next_Non_Pragma
(Comp
);
26008 -- Check variant part
26010 Vpart
:= Variant_Part
(Clist
);
26012 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
26013 while Present
(Variant
) loop
26014 Check_Variant
(Variant
, Typ
);
26015 Next_Non_Pragma
(Variant
);
26019 Set_Is_Unchecked_Union
(Typ
);
26020 Set_Convention
(Typ
, Convention_C
);
26021 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
26022 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
26023 end Unchecked_Union
;
26025 ----------------------------
26026 -- Unevaluated_Use_Of_Old --
26027 ----------------------------
26029 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
26031 when Pragma_Unevaluated_Use_Of_Old
=>
26033 Check_Arg_Count
(1);
26034 Check_No_Identifiers
;
26035 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
26037 -- Suppress/Unsuppress can appear as a configuration pragma, or in
26038 -- a declarative part or a package spec.
26040 if not Is_Configuration_Pragma
then
26041 Check_Is_In_Decl_Part_Or_Package_Spec
;
26044 -- Store proper setting of Uneval_Old
26046 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
26047 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
26049 ------------------------
26050 -- Unimplemented_Unit --
26051 ------------------------
26053 -- pragma Unimplemented_Unit;
26055 -- Note: this only gives an error if we are generating code, or if
26056 -- we are in a generic library unit (where the pragma appears in the
26057 -- body, not in the spec).
26059 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
26060 Cunitent
: constant Entity_Id
:=
26061 Cunit_Entity
(Get_Source_Unit
(Loc
));
26065 Check_Arg_Count
(0);
26067 if Operating_Mode
= Generate_Code
26068 or else Is_Generic_Unit
(Cunitent
)
26070 Get_Name_String
(Chars
(Cunitent
));
26071 Set_Casing
(Mixed_Case
);
26072 Write_Str
(Name_Buffer
(1 .. Name_Len
));
26073 Write_Str
(" is not supported in this configuration");
26075 raise Unrecoverable_Error
;
26077 end Unimplemented_Unit
;
26079 ------------------------
26080 -- Universal_Aliasing --
26081 ------------------------
26083 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
26085 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
26091 Check_Arg_Count
(1);
26092 Check_Optional_Identifier
(Arg2
, Name_Entity
);
26093 Check_Arg_Is_Local_Name
(Arg1
);
26094 E_Id
:= Get_Pragma_Arg
(Arg1
);
26096 if Etype
(E_Id
) = Any_Type
then
26100 E
:= Entity
(E_Id
);
26102 if not Is_Type
(E
) then
26103 Error_Pragma_Arg
("pragma% requires type", Arg1
);
26106 -- A pragma that applies to a Ghost entity becomes Ghost for the
26107 -- purposes of legality checks and removal of ignored Ghost code.
26109 Mark_Ghost_Pragma
(N
, E
);
26110 Set_Universal_Aliasing
(Base_Type
(E
));
26111 Record_Rep_Item
(E
, N
);
26112 end Universal_Alias
;
26118 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
26120 when Pragma_Unmodified
=>
26121 Analyze_Unmodified_Or_Unused
;
26127 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
26129 -- or when used in a context clause:
26131 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
26133 when Pragma_Unreferenced
=>
26134 Analyze_Unreferenced_Or_Unused
;
26136 --------------------------
26137 -- Unreferenced_Objects --
26138 --------------------------
26140 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
26142 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
26144 Arg_Expr
: Node_Id
;
26145 Arg_Id
: Entity_Id
;
26147 Ghost_Error_Posted
: Boolean := False;
26148 -- Flag set when an error concerning the illegal mix of Ghost and
26149 -- non-Ghost types is emitted.
26151 Ghost_Id
: Entity_Id
:= Empty
;
26152 -- The entity of the first Ghost type encountered while processing
26153 -- the arguments of the pragma.
26157 Check_At_Least_N_Arguments
(1);
26160 while Present
(Arg
) loop
26161 Check_No_Identifier
(Arg
);
26162 Check_Arg_Is_Local_Name
(Arg
);
26163 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
26165 if Is_Entity_Name
(Arg_Expr
) then
26166 Arg_Id
:= Entity
(Arg_Expr
);
26168 if Is_Type
(Arg_Id
) then
26169 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
26171 -- A pragma that applies to a Ghost entity becomes Ghost
26172 -- for the purposes of legality checks and removal of
26173 -- ignored Ghost code.
26175 Mark_Ghost_Pragma
(N
, Arg_Id
);
26177 -- Capture the entity of the first Ghost type being
26178 -- processed for error detection purposes.
26180 if Is_Ghost_Entity
(Arg_Id
) then
26181 if No
(Ghost_Id
) then
26182 Ghost_Id
:= Arg_Id
;
26185 -- Otherwise the type is non-Ghost. It is illegal to mix
26186 -- references to Ghost and non-Ghost entities
26189 elsif Present
(Ghost_Id
)
26190 and then not Ghost_Error_Posted
26192 Ghost_Error_Posted
:= True;
26194 Error_Msg_Name_1
:= Pname
;
26196 ("pragma % cannot mention ghost and non-ghost types",
26199 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
26200 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
26202 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
26203 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
26207 ("argument for pragma% must be type or subtype", Arg
);
26211 ("argument for pragma% must be type or subtype", Arg
);
26216 end Unreferenced_Objects
;
26218 ------------------------------
26219 -- Unreserve_All_Interrupts --
26220 ------------------------------
26222 -- pragma Unreserve_All_Interrupts;
26224 when Pragma_Unreserve_All_Interrupts
=>
26226 Check_Arg_Count
(0);
26228 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
26229 Unreserve_All_Interrupts
:= True;
26236 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
26238 when Pragma_Unsuppress
=>
26240 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
26246 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
26248 when Pragma_Unused
=>
26249 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
26250 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
26252 -------------------
26253 -- Use_VADS_Size --
26254 -------------------
26256 -- pragma Use_VADS_Size;
26258 when Pragma_Use_VADS_Size
=>
26260 Check_Arg_Count
(0);
26261 Check_Valid_Configuration_Pragma
;
26262 Use_VADS_Size
:= True;
26264 ----------------------------
26265 -- User_Aspect_Definition --
26266 ----------------------------
26268 -- pragma User_Aspect_Definition
26269 -- (Identifier, {, Identifier [(Identifier {, Identifier})]});
26271 when Pragma_User_Aspect_Definition
=>
26273 Check_Valid_Configuration_Pragma
;
26276 First
(Pragma_Argument_Associations
(N
));
26277 User_Aspect_Name
: constant Name_Id
:= Chars
(Expression
(Arg
));
26279 Aspect
: Aspect_Id
;
26281 if Get_Aspect_Id
(User_Aspect_Name
) /= No_Aspect
then
26283 ("User-defined aspect name for pragma% is the name " &
26284 "of an existing aspect", Arg
);
26287 Next
(Arg
); -- skip first argument, the name of the aspect
26289 while Present
(Arg
) loop
26290 Expr
:= Expression
(Arg
);
26291 case Nkind
(Expr
) is
26292 when N_Identifier
=>
26293 Aspect
:= Get_Aspect_Id
(Chars
(Expr
));
26294 if Aspect
in Boolean_Aspects
26295 and not Is_Representation_Aspect
(Aspect
)
26297 -- If we allowed representation aspects such as
26298 -- Pack here, then User_Aspect itself would need
26299 -- to be a representation aspect.
26302 elsif Aspect
= No_Aspect
and then
26303 Present
(User_Aspect_Support
.Registered_UAD_Pragma
26304 (User_Aspect_Name
))
26309 ("unparameterized argument for pragma% must be " &
26310 "either a Boolean-valued non-representation " &
26311 "aspect or user-defined", Arg
);
26313 when N_Indexed_Component
=>
26314 Aspect
:= Get_Aspect_Id
(Chars
(Prefix
(Expr
)));
26316 -- Aspect should be an aspect that takes
26317 -- identifier arguments that do not refer to
26318 -- declarations, but rather to undeclared entities
26319 -- such as GNATProve or No_Secondary_Stack for
26320 -- which the notion of visibility does not apply.
26323 when Aspect_Annotate
=>
26324 if List_Length
(Expressions
(Expr
)) /= 2 then
26326 ("Annotate argument for pragma% takes " &
26327 "two parameters", Arg
);
26330 when Aspect_Local_Restrictions
=>
26335 ("parameterized argument for pragma% must be " &
26336 "Annotate or Local_Restrictions aspect", Arg
);
26339 raise Program_Error
; -- parsing error
26345 Registered
: constant Node_Id
:=
26346 User_Aspect_Support
.Registered_UAD_Pragma
26347 (User_Aspect_Name
);
26349 -- Given two User_Aspect_Definition pragmas with
26350 -- matching names for the first argument, check that
26351 -- subsequent arguments also match; complain if they differ.
26352 procedure Check_UAD_Conformance
26353 (New_Pragma
, Old_Pragma
: Node_Id
);
26355 ---------------------------
26356 -- Check_UAD_Conformance --
26357 ---------------------------
26359 procedure Check_UAD_Conformance
26360 (New_Pragma
, Old_Pragma
: Node_Id
)
26362 Old_Arg
: Node_Id
:=
26363 First
(Pragma_Argument_Associations
(Old_Pragma
));
26364 New_Arg
: Node_Id
:=
26365 First
(Pragma_Argument_Associations
(New_Pragma
));
26366 OK
: Boolean := True;
26368 function Same_Chars
(Id1
, Id2
: Node_Id
) return Boolean
26369 is (Chars
(Id1
) = Chars
(Id2
));
26371 function Same_Identifier_List
(Id1
, Id2
: Node_Id
)
26373 is (if No
(Id1
) and No
(Id2
) then True
26374 elsif No
(Id1
) or No
(Id2
) then False
26375 else (Same_Chars
(Id1
, Id2
) and then
26376 Same_Identifier_List
(Next
(Id1
), Next
(Id2
))));
26378 -- We could skip the first argument pair since those
26379 -- are already known to match (or we wouldn't be
26380 -- calling this procedure).
26382 while Present
(Old_Arg
) or Present
(New_Arg
) loop
26383 if Present
(Old_Arg
) /= Present
(New_Arg
) then
26385 elsif Nkind
(Expression
(Old_Arg
)) /=
26386 Nkind
(Expression
(New_Arg
))
26390 case Nkind
(Expression
(Old_Arg
)) is
26391 when N_Identifier
=>
26392 OK
:= Same_Chars
(Expression
(Old_Arg
),
26393 Expression
(New_Arg
));
26395 when N_Indexed_Component
=>
26397 (Prefix
(Expression
(Old_Arg
)),
26398 Prefix
(Expression
(New_Arg
)))
26399 and then Same_Identifier_List
26400 (First
(Expressions
26401 (Expression
(Old_Arg
))),
26403 (Expression
(New_Arg
))));
26407 pragma Assert
(False);
26412 Error_Msg_Sloc
:= Sloc
(Old_Pragma
);
26414 ("Nonconforming definitions for user-defined " &
26415 "aspect #", New_Pragma
);
26422 end Check_UAD_Conformance
;
26424 if Present
(Registered
) then
26425 -- If we have already seen a UAD pragma with this name,
26426 -- then check that the two pragmas conform (which means
26427 -- that the new pragma is redundant and can be ignored).
26429 -- ??? We could also perform a similar bind-time check,
26430 -- since it is possible that an incompatible pair of
26431 -- UAD pragmas might not be detected by this check.
26432 -- This could arise if no unit's compilation closure
26433 -- includes both of the two. The major downside of
26434 -- failing to detect this case is possible confusion
26435 -- for human readers.
26437 Check_UAD_Conformance
(New_Pragma
=> N
,
26438 Old_Pragma
=> Registered
);
26440 User_Aspect_Support
.Register_UAD_Pragma
(N
);
26445 ---------------------
26446 -- Validity_Checks --
26447 ---------------------
26449 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
26451 when Pragma_Validity_Checks
=> Validity_Checks
: declare
26452 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
26458 Check_Arg_Count
(1);
26459 Check_No_Identifiers
;
26461 -- Pragma always active unless in CodePeer or GNATprove modes,
26462 -- which use a fixed configuration of validity checks.
26464 if not (CodePeer_Mode
or GNATprove_Mode
) then
26465 if Nkind
(A
) = N_String_Literal
then
26469 Slen
: constant Natural := Natural (String_Length
(S
));
26470 Options
: String (1 .. Slen
);
26474 -- Couldn't we use a for loop here over Options'Range???
26478 C
:= Get_String_Char
(S
, Pos
(J
));
26480 -- This is a weird test, it skips setting validity
26481 -- checks entirely if any element of S is out of
26482 -- range of Character, what is that about ???
26484 exit when not In_Character_Range
(C
);
26485 Options
(J
) := Get_Character
(C
);
26488 Set_Validity_Check_Options
(Options
);
26496 elsif Nkind
(A
) = N_Identifier
then
26497 if Chars
(A
) = Name_All_Checks
then
26498 Set_Validity_Check_Options
("a");
26499 elsif Chars
(A
) = Name_On
then
26500 Validity_Checks_On
:= True;
26501 elsif Chars
(A
) = Name_Off
then
26502 Validity_Checks_On
:= False;
26506 end Validity_Checks
;
26512 -- pragma Volatile (LOCAL_NAME);
26514 when Pragma_Volatile
=>
26515 Process_Atomic_Independent_Shared_Volatile
;
26517 -------------------------
26518 -- Volatile_Components --
26519 -------------------------
26521 -- pragma Volatile_Components (array_LOCAL_NAME);
26523 -- Volatile is handled by the same circuit as Atomic_Components
26525 --------------------------
26526 -- Volatile_Full_Access --
26527 --------------------------
26529 -- pragma Volatile_Full_Access (LOCAL_NAME);
26531 when Pragma_Volatile_Full_Access
=>
26533 Process_Atomic_Independent_Shared_Volatile
;
26535 -----------------------
26536 -- Volatile_Function --
26537 -----------------------
26539 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
26541 when Pragma_Volatile_Function
=> Volatile_Function
: declare
26542 Over_Id
: Entity_Id
;
26543 Spec_Id
: Entity_Id
;
26544 Subp_Decl
: Node_Id
;
26548 Check_No_Identifiers
;
26549 Check_At_Most_N_Arguments
(1);
26552 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
26554 -- Generic subprogram
26556 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
26559 -- Body acts as spec
26561 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
26562 and then No
(Corresponding_Spec
(Subp_Decl
))
26566 -- Body stub acts as spec
26568 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
26569 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
26575 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
26582 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26584 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
26588 -- A pragma that applies to a Ghost entity becomes Ghost for the
26589 -- purposes of legality checks and removal of ignored Ghost code.
26591 Mark_Ghost_Pragma
(N
, Spec_Id
);
26593 -- Chain the pragma on the contract for completeness
26595 Add_Contract_Item
(N
, Spec_Id
);
26597 -- The legality checks of pragma Volatile_Function are affected by
26598 -- the SPARK mode in effect. Analyze all pragmas in a specific
26601 Analyze_If_Present
(Pragma_SPARK_Mode
);
26603 -- A volatile function cannot override a non-volatile function
26604 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
26605 -- in New_Overloaded_Entity, however at that point the pragma has
26606 -- not been processed yet.
26608 Over_Id
:= Overridden_Operation
(Spec_Id
);
26610 if Present
(Over_Id
)
26611 and then not Is_Volatile_Function
(Over_Id
)
26614 ("incompatible volatile function values in effect", Spec_Id
);
26616 Error_Msg_Sloc
:= Sloc
(Over_Id
);
26618 ("\& declared # with Volatile_Function value False",
26621 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
26623 ("\overridden # with Volatile_Function value True",
26627 -- Analyze the Boolean expression (if any)
26629 if Present
(Arg1
) then
26630 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
26632 end Volatile_Function
;
26634 ----------------------
26635 -- Warning_As_Error --
26636 ----------------------
26638 -- pragma Warning_As_Error (static_string_EXPRESSION);
26640 when Pragma_Warning_As_Error
=>
26642 Check_Arg_Count
(1);
26643 Check_No_Identifiers
;
26644 Check_Valid_Configuration_Pragma
;
26646 if not Is_Static_String_Expression
(Arg1
) then
26648 ("argument of pragma% must be static string expression",
26651 -- OK static string expression
26654 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
26655 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
26656 new String'(Acquire_Warning_Match_String
26657 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
26664 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
26666 -- DETAILS ::= On | Off
26667 -- DETAILS ::= On | Off, local_NAME
26668 -- DETAILS ::= static_string_EXPRESSION
26669 -- DETAILS ::= On | Off, static_string_EXPRESSION
26671 -- TOOL_NAME ::= GNAT | GNATprove
26673 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
26675 -- Note: If the first argument matches an allowed tool name, it is
26676 -- always considered to be a tool name, even if there is a string
26677 -- variable of that name.
26679 -- Note if the second argument of DETAILS is a local_NAME then the
26680 -- second form is always understood. If the intention is to use
26681 -- the fourth form, then you can write NAME & "" to force the
26682 -- intepretation as a static_string_EXPRESSION.
26684 when Pragma_Warnings => Warnings : declare
26685 Reason : String_Id;
26689 Check_At_Least_N_Arguments (1);
26691 -- See if last argument is labeled Reason. If so, make sure we
26692 -- have a string literal or a concatenation of string literals,
26693 -- and acquire the REASON string. Then remove the REASON argument
26694 -- by decreasing Num_Args by one; Remaining processing looks only
26695 -- at first Num_Args arguments).
26698 Last_Arg : constant Node_Id :=
26699 Last (Pragma_Argument_Associations (N));
26702 if Nkind (Last_Arg) = N_Pragma_Argument_Association
26703 and then Chars (Last_Arg) = Name_Reason
26706 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
26707 Reason := End_String;
26708 Arg_Count := Arg_Count - 1;
26710 -- No REASON string, set null string as reason
26713 Reason := Null_String_Id;
26717 -- Now proceed with REASON taken care of and eliminated
26719 Check_No_Identifiers;
26721 -- If debug flag -gnatd.i is set, pragma is ignored
26723 if Debug_Flag_Dot_I then
26727 -- Process various forms of the pragma
26730 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
26731 Shifted_Args : List_Id;
26734 -- See if first argument is a tool name, currently either
26735 -- GNAT or GNATprove. If so, either ignore the pragma if the
26736 -- tool used does not match, or continue as if no tool name
26737 -- was given otherwise, by shifting the arguments.
26739 if Nkind (Argx) = N_Identifier
26740 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
26742 if Chars (Argx) = Name_Gnat then
26743 if CodePeer_Mode or GNATprove_Mode then
26744 Rewrite (N, Make_Null_Statement (Loc));
26749 elsif Chars (Argx) = Name_Gnatprove then
26750 if not GNATprove_Mode then
26751 Rewrite (N, Make_Null_Statement (Loc));
26756 raise Program_Error;
26759 -- At this point, the pragma Warnings applies to the tool,
26760 -- so continue with shifted arguments.
26762 Arg_Count := Arg_Count - 1;
26764 if Arg_Count = 1 then
26765 Shifted_Args := New_List (New_Copy (Arg2));
26766 elsif Arg_Count = 2 then
26767 Shifted_Args := New_List (New_Copy (Arg2),
26769 elsif Arg_Count = 3 then
26770 Shifted_Args := New_List (New_Copy (Arg2),
26774 raise Program_Error;
26779 Chars => Name_Warnings,
26780 Pragma_Argument_Associations => Shifted_Args));
26785 -- One argument case
26787 if Arg_Count = 1 then
26789 -- On/Off one argument case was processed by parser
26791 if Nkind (Argx) = N_Identifier
26792 and then Chars (Argx) in Name_On | Name_Off
26796 -- One argument case must be ON/OFF or static string expr
26798 elsif not Is_Static_String_Expression (Arg1) then
26800 ("argument of pragma% must be On/Off or static string "
26801 & "expression", Arg1);
26803 -- Use of pragma Warnings to set warning switches is
26804 -- ignored in GNATprove mode, as these switches apply to
26805 -- the compiler only.
26807 elsif GNATprove_Mode then
26810 -- One argument string expression case
26814 Lit : constant Node_Id := Expr_Value_S (Argx);
26815 Str : constant String_Id := Strval (Lit);
26816 Len : constant Nat := String_Length (Str);
26824 while J <= Len loop
26825 C := Get_String_Char (Str, J);
26826 OK := In_Character_Range (C);
26829 Chr := Get_Character (C);
26831 -- Dash case: only -Wxxx is accepted
26838 C := Get_String_Char (Str, J);
26839 Chr := Get_Character (C);
26840 exit when Chr = 'W
';
26845 elsif J < Len and then Chr = '.' then
26847 C := Get_String_Char (Str, J);
26848 Chr := Get_Character (C);
26850 if not Set_Warning_Switch ('.', Chr) then
26852 ("invalid warning switch character "
26853 & '.' & Chr, Arg1);
26859 OK := Set_Warning_Switch (Plain, Chr);
26864 ("invalid warning switch character " & Chr,
26870 ("invalid wide character in warning switch ",
26879 -- Two or more arguments (must be two)
26882 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
26883 Check_Arg_Count (2);
26891 E_Id := Get_Pragma_Arg (Arg2);
26894 -- In the expansion of an inlined body, a reference to
26895 -- the formal may be wrapped in a conversion if the
26896 -- actual is a conversion. Retrieve the real entity name.
26898 if (In_Instance_Body or In_Inlined_Body)
26899 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
26901 E_Id := Expression (E_Id);
26904 -- Entity name case
26906 if Is_Entity_Name (E_Id) then
26907 E := Entity (E_Id);
26914 (E, (Chars (Get_Pragma_Arg (Arg1)) =
26917 -- Suppress elaboration warnings if the entity
26918 -- denotes an elaboration target.
26920 if Is_Elaboration_Target (E) then
26921 Set_Is_Elaboration_Warnings_OK_Id (E, False);
26924 -- For OFF case, make entry in warnings off
26925 -- pragma table for later processing. But we do
26926 -- not do that within an instance, since these
26927 -- warnings are about what is needed in the
26928 -- template, not an instance of it.
26930 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
26931 and then Warn_On_Warnings_Off
26932 and then not In_Instance
26934 Warnings_Off_Pragmas.Append ((N, E, Reason));
26937 if Is_Enumeration_Type (E) then
26941 Lit := First_Literal (E);
26942 while Present (Lit) loop
26943 Set_Warnings_Off (Lit);
26944 Next_Literal (Lit);
26949 exit when No (Homonym (E));
26954 -- Error if not entity or static string expression case
26956 elsif not Is_Static_String_Expression (Arg2) then
26958 ("second argument of pragma% must be entity name "
26959 & "or static string expression", Arg2);
26961 -- Static string expression case
26964 -- Note on configuration pragma case: If this is a
26965 -- configuration pragma, then for an OFF pragma, we
26966 -- just set Config True in the call, which is all
26967 -- that needs to be done. For the case of ON, this
26968 -- is normally an error, unless it is canceling the
26969 -- effect of a previous OFF pragma in the same file.
26970 -- In any other case, an error will be signalled (ON
26971 -- with no matching OFF).
26973 -- Note: We set Used if we are inside a generic to
26974 -- disable the test that the non-config case actually
26975 -- cancels a warning. That's because we can't be sure
26976 -- there isn't an instantiation in some other unit
26977 -- where a warning is suppressed.
26979 -- We could do a little better here by checking if the
26980 -- generic unit we are inside is public, but for now
26981 -- we don't bother with that refinement.
26984 Message : constant String :=
26985 Acquire_Warning_Match_String
26986 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
26988 if Chars (Argx) = Name_Off then
26989 Set_Specific_Warning_Off
26990 (Loc, Message, Reason,
26991 Config => Is_Configuration_Pragma,
26992 Used => Inside_A_Generic or else In_Instance);
26994 elsif Chars (Argx) = Name_On then
26995 Set_Specific_Warning_On (Loc, Message, Err);
26999 ("??pragma Warnings On with no matching "
27000 & "Warnings Off", N);
27010 -------------------
27011 -- Weak_External --
27012 -------------------
27014 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
27016 when Pragma_Weak_External => Weak_External : declare
27021 Check_Arg_Count (1);
27022 Check_Optional_Identifier (Arg1, Name_Entity);
27023 Check_Arg_Is_Library_Level_Local_Name (Arg1);
27024 Ent := Entity (Get_Pragma_Arg (Arg1));
27026 if Rep_Item_Too_Early (Ent, N) then
27029 Ent := Underlying_Type (Ent);
27032 -- The pragma applies to entities with addresses
27034 if Is_Type (Ent) then
27035 Error_Pragma ("pragma applies to objects and subprograms");
27038 -- The only processing required is to link this item on to the
27039 -- list of rep items for the given entity. This is accomplished
27040 -- by the call to Rep_Item_Too_Late (when no error is detected
27041 -- and False is returned).
27043 if Rep_Item_Too_Late (Ent, N) then
27046 Set_Has_Gigi_Rep_Item (Ent);
27050 -----------------------------
27051 -- Wide_Character_Encoding --
27052 -----------------------------
27054 -- pragma Wide_Character_Encoding (IDENTIFIER);
27056 when Pragma_Wide_Character_Encoding =>
27059 -- Nothing to do, handled in parser. Note that we do not enforce
27060 -- configuration pragma placement, this pragma can appear at any
27061 -- place in the source, allowing mixed encodings within a single
27066 --------------------
27067 -- Unknown_Pragma --
27068 --------------------
27070 -- Should be impossible, since the case of an unknown pragma is
27071 -- separately processed before the case statement is entered.
27073 when Unknown_Pragma =>
27074 raise Program_Error;
27077 -- AI05-0144: detect dangerous order dependence. Disabled for now,
27078 -- until AI is formally approved.
27080 -- Check_Order_Dependence;
27083 when Pragma_Exit => null;
27084 end Analyze_Pragma;
27086 --------------------------------
27087 -- Analyze_Pragmas_If_Present --
27088 --------------------------------
27090 procedure Analyze_Pragmas_If_Present (Decl : Node_Id; Id : Pragma_Id) is
27093 if Nkind (Parent (Decl)) = N_Compilation_Unit then
27094 Prag := First (Pragmas_After (Aux_Decls_Node (Parent (Decl))));
27096 pragma Assert (Is_List_Member (Decl));
27097 Prag := Next (Decl);
27100 if Present (Prag) then
27101 Analyze_If_Present_Internal (Prag, Id, Included => True);
27103 end Analyze_Pragmas_If_Present;
27105 ---------------------------------------------
27106 -- Analyze_Pre_Post_Condition_In_Decl_Part --
27107 ---------------------------------------------
27109 -- WARNING: This routine manages Ghost regions. Return statements must be
27110 -- replaced by gotos which jump to the end of the routine and restore the
27113 procedure Analyze_Pre_Post_Condition_In_Decl_Part
27115 Freeze_Id : Entity_Id := Empty)
27117 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27118 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27120 Disp_Typ : Entity_Id;
27121 -- The dispatching type of the subprogram subject to the pre- or
27124 function Check_References (Nod : Node_Id) return Traverse_Result;
27125 -- Check that expression Nod does not mention non-primitives of the
27126 -- type, global objects of the type, or other illegalities described
27127 -- and implied by AI12-0113.
27129 ----------------------
27130 -- Check_References --
27131 ----------------------
27133 function Check_References (Nod : Node_Id) return Traverse_Result is
27135 if Nkind (Nod) = N_Function_Call
27136 and then Is_Entity_Name (Name (Nod))
27139 Func : constant Entity_Id := Entity (Name (Nod));
27143 -- An operation of the type must be a primitive
27145 if No (Find_Dispatching_Type (Func)) then
27146 Form := First_Formal (Func);
27147 while Present (Form) loop
27148 if Etype (Form) = Disp_Typ then
27150 ("operation in class-wide condition must be "
27151 & "primitive of &", Nod, Disp_Typ);
27154 Next_Formal (Form);
27157 -- A return object of the type is illegal as well
27159 if Etype (Func) = Disp_Typ
27160 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
27163 ("operation in class-wide condition must be primitive "
27164 & "of &", Nod, Disp_Typ);
27169 elsif Is_Entity_Name (Nod)
27171 (Etype (Nod) = Disp_Typ
27172 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27173 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
27176 ("object in class-wide condition must be formal of type &",
27179 elsif Nkind (Nod) = N_Explicit_Dereference
27180 and then (Etype (Nod) = Disp_Typ
27181 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27182 and then (not Is_Entity_Name (Prefix (Nod))
27183 or else not Is_Formal (Entity (Prefix (Nod))))
27186 ("operation in class-wide condition must be primitive of &",
27191 end Check_References;
27193 procedure Check_Class_Wide_Condition is
27194 new Traverse_Proc (Check_References);
27198 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27200 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
27201 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
27202 -- Save the Ghost-related attributes to restore on exit
27205 Restore_Scope : Boolean := False;
27207 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
27210 -- Do not analyze the pragma multiple times
27212 if Is_Analyzed_Pragma (N) then
27216 -- Set the Ghost mode in effect from the pragma. Due to the delayed
27217 -- analysis of the pragma, the Ghost mode at point of declaration and
27218 -- point of analysis may not necessarily be the same. Use the mode in
27219 -- effect at the point of declaration.
27221 Set_Ghost_Mode (N);
27223 -- Ensure that the subprogram and its formals are visible when analyzing
27224 -- the expression of the pragma.
27226 if not In_Open_Scopes (Spec_Id) then
27227 Restore_Scope := True;
27229 if Is_Generic_Subprogram (Spec_Id) then
27230 Push_Scope (Spec_Id);
27231 Install_Generic_Formals (Spec_Id);
27232 elsif Is_Access_Subprogram_Type (Spec_Id) then
27233 Push_Scope (Designated_Type (Spec_Id));
27234 Install_Formals (Designated_Type (Spec_Id));
27236 Push_Scope (Spec_Id);
27237 Install_Formals (Spec_Id);
27241 Errors := Serious_Errors_Detected;
27242 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
27244 -- Emit a clarification message when the expression contains at least
27245 -- one undefined reference, possibly due to contract freezing.
27247 if Errors /= Serious_Errors_Detected
27248 and then Present (Freeze_Id)
27249 and then Has_Undefined_Reference (Expr)
27251 Contract_Freeze_Error (Spec_Id, Freeze_Id);
27254 if Class_Present (N) then
27256 -- Verify that a class-wide condition is legal, i.e. the operation is
27257 -- a primitive of a tagged type.
27259 if not Is_Dispatching_Operation (Spec_Id) then
27260 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
27262 if From_Aspect_Specification (N) then
27264 ("aspect % can only be specified for a primitive operation "
27265 & "of a tagged type", Corresponding_Aspect (N));
27267 -- The pragma is a source construct
27271 ("pragma % can only be specified for a primitive operation "
27272 & "of a tagged type", N);
27275 -- Remaining semantic checks require a full tree traversal
27278 Disp_Typ := Find_Dispatching_Type (Spec_Id);
27279 Check_Class_Wide_Condition (Expr);
27284 if Restore_Scope then
27288 -- Currently it is not possible to inline pre/postconditions on a
27289 -- subprogram subject to pragma Inline_Always.
27291 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27292 Set_Is_Analyzed_Pragma (N);
27294 Restore_Ghost_Region (Saved_GM, Saved_IGR);
27295 end Analyze_Pre_Post_Condition_In_Decl_Part;
27297 ------------------------------------------
27298 -- Analyze_Refined_Depends_In_Decl_Part --
27299 ------------------------------------------
27301 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
27302 procedure Check_Dependency_Clause
27303 (Spec_Id : Entity_Id;
27304 Dep_Clause : Node_Id;
27305 Dep_States : Elist_Id;
27306 Refinements : List_Id;
27307 Matched_Items : in out Elist_Id);
27308 -- Try to match a single dependency clause Dep_Clause against one or
27309 -- more refinement clauses found in list Refinements. Each successful
27310 -- match eliminates at least one refinement clause from Refinements.
27311 -- Spec_Id denotes the entity of the related subprogram. Dep_States
27312 -- denotes the entities of all abstract states which appear in pragma
27313 -- Depends. Matched_Items contains the entities of all successfully
27314 -- matched items found in pragma Depends.
27316 procedure Check_Output_States
27317 (Spec_Inputs : Elist_Id;
27318 Spec_Outputs : Elist_Id;
27319 Body_Inputs : Elist_Id;
27320 Body_Outputs : Elist_Id);
27321 -- Determine whether pragma Depends contains an output state with a
27322 -- visible refinement and if so, ensure that pragma Refined_Depends
27323 -- mentions all its constituents as outputs. Spec_Inputs and
27324 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
27325 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
27326 -- the inputs and outputs of the subprogram body synthesized from pragma
27327 -- Refined_Depends.
27329 function Collect_States (Clauses : List_Id) return Elist_Id;
27330 -- Given a normalized list of dependencies obtained from calling
27331 -- Normalize_Clauses, return a list containing the entities of all
27332 -- states appearing in dependencies. It helps in checking refinements
27333 -- involving a state and a corresponding constituent which is not a
27334 -- direct constituent of the state.
27336 procedure Normalize_Clauses (Clauses : List_Id);
27337 -- Given a list of dependence or refinement clauses Clauses, normalize
27338 -- each clause by creating multiple dependencies with exactly one input
27341 procedure Remove_Extra_Clauses
27342 (Clauses : List_Id;
27343 Matched_Items : Elist_Id);
27344 -- Given a list of refinement clauses Clauses, remove all clauses whose
27345 -- inputs and/or outputs have been previously matched. See the body for
27346 -- all special cases. Matched_Items contains the entities of all matched
27347 -- items found in pragma Depends.
27349 procedure Report_Extra_Clauses (Clauses : List_Id);
27350 -- Emit an error for each extra clause found in list Clauses
27352 -----------------------------
27353 -- Check_Dependency_Clause --
27354 -----------------------------
27356 procedure Check_Dependency_Clause
27357 (Spec_Id : Entity_Id;
27358 Dep_Clause : Node_Id;
27359 Dep_States : Elist_Id;
27360 Refinements : List_Id;
27361 Matched_Items : in out Elist_Id)
27363 Dep_Input : constant Node_Id := Expression (Dep_Clause);
27364 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
27366 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
27367 -- Determine whether dependency item Dep_Item has been matched in a
27368 -- previous clause.
27370 function Is_In_Out_State_Clause return Boolean;
27371 -- Determine whether dependence clause Dep_Clause denotes an abstract
27372 -- state that depends on itself (State => State).
27374 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
27375 -- Determine whether item Item denotes an abstract state with visible
27376 -- null refinement.
27378 procedure Match_Items
27379 (Dep_Item : Node_Id;
27380 Ref_Item : Node_Id;
27381 Matched : out Boolean);
27382 -- Try to match dependence item Dep_Item against refinement item
27383 -- Ref_Item. To match against a possible null refinement (see 2, 9),
27384 -- set Ref_Item to Empty. Flag Matched is set to True when one of
27385 -- the following conformance scenarios is in effect:
27386 -- 1) Both items denote null
27387 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
27388 -- 3) Both items denote attribute 'Result
27389 -- 4) Both items denote the same object
27390 -- 5) Both items denote the same formal parameter
27391 -- 6) Both items denote the same current instance of a type
27392 -- 7) Both items denote the same discriminant
27393 -- 8) Dep_Item is an abstract state with visible null refinement
27394 -- and Ref_Item denotes null.
27395 -- 9) Dep_Item is an abstract state with visible null refinement
27396 -- and Ref_Item is Empty (special case).
27397 -- 10) Dep_Item is an abstract state with full or partial visible
27398 -- non-null refinement and Ref_Item denotes one of its
27400 -- 11) Dep_Item is an abstract state without a full visible
27401 -- refinement and Ref_Item denotes the same state.
27402 -- When scenario 10 is in effect, the entity of the abstract state
27403 -- denoted by Dep_Item is added to list Refined_States.
27405 procedure Record_Item
(Item_Id
: Entity_Id
);
27406 -- Store the entity of an item denoted by Item_Id in Matched_Items
27408 ------------------------
27409 -- Is_Already_Matched --
27410 ------------------------
27412 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
27413 Item_Id
: Entity_Id
:= Empty
;
27416 -- When the dependency item denotes attribute 'Result, check for
27417 -- the entity of the related subprogram.
27419 if Is_Attribute_Result
(Dep_Item
) then
27420 Item_Id
:= Spec_Id
;
27422 elsif Is_Entity_Name
(Dep_Item
) then
27423 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
27427 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
27428 end Is_Already_Matched
;
27430 ----------------------------
27431 -- Is_In_Out_State_Clause --
27432 ----------------------------
27434 function Is_In_Out_State_Clause
return Boolean is
27435 Dep_Input_Id
: Entity_Id
;
27436 Dep_Output_Id
: Entity_Id
;
27439 -- Detect the following clause:
27442 if Is_Entity_Name
(Dep_Input
)
27443 and then Is_Entity_Name
(Dep_Output
)
27445 -- Handle abstract views generated for limited with clauses
27447 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
27448 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
27451 Ekind
(Dep_Input_Id
) = E_Abstract_State
27452 and then Dep_Input_Id
= Dep_Output_Id
;
27456 end Is_In_Out_State_Clause
;
27458 ---------------------------
27459 -- Is_Null_Refined_State --
27460 ---------------------------
27462 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
27463 Item_Id
: Entity_Id
;
27466 if Is_Entity_Name
(Item
) then
27468 -- Handle abstract views generated for limited with clauses
27470 Item_Id
:= Available_View
(Entity_Of
(Item
));
27473 Ekind
(Item_Id
) = E_Abstract_State
27474 and then Has_Null_Visible_Refinement
(Item_Id
);
27478 end Is_Null_Refined_State
;
27484 procedure Match_Items
27485 (Dep_Item
: Node_Id
;
27486 Ref_Item
: Node_Id
;
27487 Matched
: out Boolean)
27489 Dep_Item_Id
: Entity_Id
;
27490 Ref_Item_Id
: Entity_Id
;
27493 -- Assume that the two items do not match
27497 -- A null matches null or Empty (special case)
27499 if Nkind
(Dep_Item
) = N_Null
27500 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
27504 -- Attribute 'Result matches attribute 'Result
27506 elsif Is_Attribute_Result
(Dep_Item
)
27507 and then Is_Attribute_Result
(Ref_Item
)
27509 -- Put the entity of the related function on the list of
27510 -- matched items because attribute 'Result does not carry
27511 -- an entity similar to states and constituents.
27513 Record_Item
(Spec_Id
);
27516 -- Abstract states, current instances of concurrent types,
27517 -- discriminants, formal parameters and objects.
27519 elsif Is_Entity_Name
(Dep_Item
) then
27521 -- Handle abstract views generated for limited with clauses
27523 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
27525 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
27527 -- An abstract state with visible null refinement matches
27528 -- null or Empty (special case).
27530 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
27531 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
27533 Record_Item
(Dep_Item_Id
);
27536 -- An abstract state with visible non-null refinement
27537 -- matches one of its constituents, or itself for an
27538 -- abstract state with partial visible refinement.
27540 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
27541 if Is_Entity_Name
(Ref_Item
) then
27542 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
27544 if Ekind
(Ref_Item_Id
) in
27545 E_Abstract_State | E_Constant | E_Variable
27546 and then Present
(Encapsulating_State
(Ref_Item_Id
))
27547 and then Find_Encapsulating_State
27548 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
27550 Record_Item
(Dep_Item_Id
);
27553 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
27554 and then Ref_Item_Id
= Dep_Item_Id
27556 Record_Item
(Dep_Item_Id
);
27561 -- An abstract state without a visible refinement matches
27564 elsif Is_Entity_Name
(Ref_Item
)
27565 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
27567 Record_Item
(Dep_Item_Id
);
27571 -- A current instance of a concurrent type, discriminant,
27572 -- formal parameter or an object matches itself.
27574 elsif Is_Entity_Name
(Ref_Item
)
27575 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
27577 Record_Item
(Dep_Item_Id
);
27587 procedure Record_Item
(Item_Id
: Entity_Id
) is
27589 if No
(Matched_Items
) then
27590 Matched_Items
:= New_Elmt_List
;
27593 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
27598 Clause_Matched
: Boolean := False;
27599 Dummy
: Boolean := False;
27600 Inputs_Match
: Boolean;
27601 Next_Ref_Clause
: Node_Id
;
27602 Outputs_Match
: Boolean;
27603 Ref_Clause
: Node_Id
;
27604 Ref_Input
: Node_Id
;
27605 Ref_Output
: Node_Id
;
27607 -- Start of processing for Check_Dependency_Clause
27610 -- Do not perform this check in an instance because it was already
27611 -- performed successfully in the generic template.
27613 if In_Instance
then
27617 -- Examine all refinement clauses and compare them against the
27618 -- dependence clause.
27620 Ref_Clause
:= First
(Refinements
);
27621 while Present
(Ref_Clause
) loop
27622 Next_Ref_Clause
:= Next
(Ref_Clause
);
27624 -- Obtain the attributes of the current refinement clause
27626 Ref_Input
:= Expression
(Ref_Clause
);
27627 Ref_Output
:= First
(Choices
(Ref_Clause
));
27629 -- The current refinement clause matches the dependence clause
27630 -- when both outputs match and both inputs match. See routine
27631 -- Match_Items for all possible conformance scenarios.
27633 -- Depends Dep_Output => Dep_Input
27637 -- Refined_Depends Ref_Output => Ref_Input
27640 (Dep_Item
=> Dep_Input
,
27641 Ref_Item
=> Ref_Input
,
27642 Matched
=> Inputs_Match
);
27645 (Dep_Item
=> Dep_Output
,
27646 Ref_Item
=> Ref_Output
,
27647 Matched
=> Outputs_Match
);
27649 -- An In_Out state clause may be matched against a refinement with
27650 -- a null input or null output as long as the non-null side of the
27651 -- relation contains a valid constituent of the In_Out_State.
27653 if Is_In_Out_State_Clause
then
27655 -- Depends => (State => State)
27656 -- Refined_Depends => (null => Constit) -- OK
27659 and then not Outputs_Match
27660 and then Nkind
(Ref_Output
) = N_Null
27662 Outputs_Match
:= True;
27665 -- Depends => (State => State)
27666 -- Refined_Depends => (Constit => null) -- OK
27668 if not Inputs_Match
27669 and then Outputs_Match
27670 and then Nkind
(Ref_Input
) = N_Null
27672 Inputs_Match
:= True;
27676 -- The current refinement clause is legally constructed following
27677 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
27678 -- the pool of candidates. The search continues because a single
27679 -- dependence clause may have multiple matching refinements.
27681 if Inputs_Match
and Outputs_Match
then
27682 Clause_Matched
:= True;
27683 Remove
(Ref_Clause
);
27686 Ref_Clause
:= Next_Ref_Clause
;
27689 -- Depending on the order or composition of refinement clauses, an
27690 -- In_Out state clause may not be directly refinable.
27692 -- Refined_State => (State => (Constit_1, Constit_2))
27693 -- Depends => ((Output, State) => (Input, State))
27694 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
27696 -- Matching normalized clause (State => State) fails because there is
27697 -- no direct refinement capable of satisfying this relation. Another
27698 -- similar case arises when clauses (Constit_1 => Input) and (Output
27699 -- => Constit_2) are matched first, leaving no candidates for clause
27700 -- (State => State). Both scenarios are legal as long as one of the
27701 -- previous clauses mentioned a valid constituent of State.
27703 if not Clause_Matched
27704 and then Is_In_Out_State_Clause
27705 and then Is_Already_Matched
(Dep_Input
)
27707 Clause_Matched
:= True;
27710 -- A clause where the input is an abstract state with visible null
27711 -- refinement or a 'Result attribute is implicitly matched when the
27712 -- output has already been matched in a previous clause.
27714 -- Refined_State => (State => null)
27715 -- Depends => (Output => State) -- implicitly OK
27716 -- Refined_Depends => (Output => ...)
27717 -- Depends => (...'Result => State) -- implicitly OK
27718 -- Refined_Depends => (...'Result => ...)
27720 if not Clause_Matched
27721 and then Is_Null_Refined_State
(Dep_Input
)
27722 and then Is_Already_Matched
(Dep_Output
)
27724 Clause_Matched
:= True;
27727 -- A clause where the output is an abstract state with visible null
27728 -- refinement is implicitly matched when the input has already been
27729 -- matched in a previous clause.
27731 -- Refined_State => (State => null)
27732 -- Depends => (State => Input) -- implicitly OK
27733 -- Refined_Depends => (... => Input)
27735 if not Clause_Matched
27736 and then Is_Null_Refined_State
(Dep_Output
)
27737 and then Is_Already_Matched
(Dep_Input
)
27739 Clause_Matched
:= True;
27742 -- At this point either all refinement clauses have been examined or
27743 -- pragma Refined_Depends contains a solitary null. Only an abstract
27744 -- state with null refinement can possibly match these cases.
27746 -- Refined_State => (State => null)
27747 -- Depends => (State => null)
27748 -- Refined_Depends => null -- OK
27750 if not Clause_Matched
then
27752 (Dep_Item
=> Dep_Input
,
27754 Matched
=> Inputs_Match
);
27757 (Dep_Item
=> Dep_Output
,
27759 Matched
=> Outputs_Match
);
27761 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
27764 -- If the contents of Refined_Depends are legal, then the current
27765 -- dependence clause should be satisfied either by an explicit match
27766 -- or by one of the special cases.
27768 if not Clause_Matched
then
27770 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
27771 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
27773 end Check_Dependency_Clause
;
27775 -------------------------
27776 -- Check_Output_States --
27777 -------------------------
27779 procedure Check_Output_States
27780 (Spec_Inputs
: Elist_Id
;
27781 Spec_Outputs
: Elist_Id
;
27782 Body_Inputs
: Elist_Id
;
27783 Body_Outputs
: Elist_Id
)
27785 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27786 -- Determine whether all constituents of state State_Id with full
27787 -- visible refinement are used as outputs in pragma Refined_Depends.
27788 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
27790 -----------------------------
27791 -- Check_Constituent_Usage --
27792 -----------------------------
27794 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27795 Constits
: constant Elist_Id
:=
27796 Partial_Refinement_Constituents
(State_Id
);
27797 Constit_Elmt
: Elmt_Id
;
27798 Constit_Id
: Entity_Id
;
27799 Only_Partial
: constant Boolean :=
27800 not Has_Visible_Refinement
(State_Id
);
27801 Posted
: Boolean := False;
27804 if Present
(Constits
) then
27805 Constit_Elmt
:= First_Elmt
(Constits
);
27806 while Present
(Constit_Elmt
) loop
27807 Constit_Id
:= Node
(Constit_Elmt
);
27809 -- Issue an error when a constituent of State_Id is used,
27810 -- and State_Id has only partial visible refinement
27811 -- (SPARK RM 7.2.4(3d)).
27813 if Only_Partial
then
27814 if (Present
(Body_Inputs
)
27815 and then Appears_In
(Body_Inputs
, Constit_Id
))
27817 (Present
(Body_Outputs
)
27818 and then Appears_In
(Body_Outputs
, Constit_Id
))
27820 Error_Msg_Name_1
:= Chars
(State_Id
);
27822 ("constituent & of state % cannot be used in "
27823 & "dependence refinement", N
, Constit_Id
);
27824 Error_Msg_Name_1
:= Chars
(State_Id
);
27825 SPARK_Msg_N
("\use state % instead", N
);
27828 -- The constituent acts as an input (SPARK RM 7.2.5(3))
27830 elsif Present
(Body_Inputs
)
27831 and then Appears_In
(Body_Inputs
, Constit_Id
)
27833 Error_Msg_Name_1
:= Chars
(State_Id
);
27835 ("constituent & of state % must act as output in "
27836 & "dependence refinement", N
, Constit_Id
);
27838 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27840 elsif No
(Body_Outputs
)
27841 or else not Appears_In
(Body_Outputs
, Constit_Id
)
27846 ("output state & must be replaced by all its "
27847 & "constituents in dependence refinement",
27852 ("\constituent & is missing in output list",
27856 Next_Elmt
(Constit_Elmt
);
27859 end Check_Constituent_Usage
;
27864 Item_Elmt
: Elmt_Id
;
27865 Item_Id
: Entity_Id
;
27867 -- Start of processing for Check_Output_States
27870 -- Do not perform this check in an instance because it was already
27871 -- performed successfully in the generic template.
27873 if In_Instance
then
27876 -- Inspect the outputs of pragma Depends looking for a state with a
27877 -- visible refinement.
27879 elsif Present
(Spec_Outputs
) then
27880 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
27881 while Present
(Item_Elmt
) loop
27882 Item
:= Node
(Item_Elmt
);
27884 -- Deal with the mixed nature of the input and output lists
27886 if Nkind
(Item
) = N_Defining_Identifier
then
27889 Item_Id
:= Available_View
(Entity_Of
(Item
));
27892 if Ekind
(Item_Id
) = E_Abstract_State
then
27894 -- The state acts as an input-output, skip it
27896 if Present
(Spec_Inputs
)
27897 and then Appears_In
(Spec_Inputs
, Item_Id
)
27901 -- Ensure that all of the constituents are utilized as
27902 -- outputs in pragma Refined_Depends.
27904 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27905 Check_Constituent_Usage
(Item_Id
);
27909 Next_Elmt
(Item_Elmt
);
27912 end Check_Output_States
;
27914 --------------------
27915 -- Collect_States --
27916 --------------------
27918 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
27919 procedure Collect_State
27921 States
: in out Elist_Id
);
27922 -- Add the entity of Item to list States when it denotes to a state
27924 -------------------
27925 -- Collect_State --
27926 -------------------
27928 procedure Collect_State
27930 States
: in out Elist_Id
)
27935 if Is_Entity_Name
(Item
) then
27936 Id
:= Entity_Of
(Item
);
27938 if Ekind
(Id
) = E_Abstract_State
then
27939 if No
(States
) then
27940 States
:= New_Elmt_List
;
27943 Append_Unique_Elmt
(Id
, States
);
27953 States
: Elist_Id
:= No_Elist
;
27955 -- Start of processing for Collect_States
27958 Clause
:= First
(Clauses
);
27959 while Present
(Clause
) loop
27960 Input
:= Expression
(Clause
);
27961 Output
:= First
(Choices
(Clause
));
27963 Collect_State
(Input
, States
);
27964 Collect_State
(Output
, States
);
27970 end Collect_States
;
27972 -----------------------
27973 -- Normalize_Clauses --
27974 -----------------------
27976 procedure Normalize_Clauses
(Clauses
: List_Id
) is
27977 procedure Normalize_Inputs
(Clause
: Node_Id
);
27978 -- Normalize clause Clause by creating multiple clauses for each
27979 -- input item of Clause. It is assumed that Clause has exactly one
27980 -- output. The transformation is as follows:
27982 -- Output => (Input_1, Input_2) -- original
27984 -- Output => Input_1 -- normalizations
27985 -- Output => Input_2
27987 procedure Normalize_Outputs
(Clause
: Node_Id
);
27988 -- Normalize clause Clause by creating multiple clause for each
27989 -- output item of Clause. The transformation is as follows:
27991 -- (Output_1, Output_2) => Input -- original
27993 -- Output_1 => Input -- normalization
27994 -- Output_2 => Input
27996 ----------------------
27997 -- Normalize_Inputs --
27998 ----------------------
28000 procedure Normalize_Inputs
(Clause
: Node_Id
) is
28001 Inputs
: constant Node_Id
:= Expression
(Clause
);
28002 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
28003 Output
: constant List_Id
:= Choices
(Clause
);
28004 Last_Input
: Node_Id
;
28006 New_Clause
: Node_Id
;
28007 Next_Input
: Node_Id
;
28010 -- Normalization is performed only when the original clause has
28011 -- more than one input. Multiple inputs appear as an aggregate.
28013 if Nkind
(Inputs
) = N_Aggregate
then
28014 Last_Input
:= Last
(Expressions
(Inputs
));
28016 -- Create a new clause for each input
28018 Input
:= First
(Expressions
(Inputs
));
28019 while Present
(Input
) loop
28020 Next_Input
:= Next
(Input
);
28022 -- Unhook the current input from the original input list
28023 -- because it will be relocated to a new clause.
28027 -- Special processing for the last input. At this point the
28028 -- original aggregate has been stripped down to one element.
28029 -- Replace the aggregate by the element itself.
28031 if Input
= Last_Input
then
28032 Rewrite
(Inputs
, Input
);
28034 -- Generate a clause of the form:
28039 Make_Component_Association
(Loc
,
28040 Choices
=> New_Copy_List_Tree
(Output
),
28041 Expression
=> Input
);
28043 -- The new clause contains replicated content that has
28044 -- already been analyzed, mark the clause as analyzed.
28046 Set_Analyzed
(New_Clause
);
28047 Insert_After
(Clause
, New_Clause
);
28050 Input
:= Next_Input
;
28053 end Normalize_Inputs
;
28055 -----------------------
28056 -- Normalize_Outputs --
28057 -----------------------
28059 procedure Normalize_Outputs
(Clause
: Node_Id
) is
28060 Inputs
: constant Node_Id
:= Expression
(Clause
);
28061 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
28062 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
28063 Last_Output
: Node_Id
;
28064 New_Clause
: Node_Id
;
28065 Next_Output
: Node_Id
;
28069 -- Multiple outputs appear as an aggregate. Nothing to do when
28070 -- the clause has exactly one output.
28072 if Nkind
(Outputs
) = N_Aggregate
then
28073 Last_Output
:= Last
(Expressions
(Outputs
));
28075 -- Create a clause for each output. Note that each time a new
28076 -- clause is created, the original output list slowly shrinks
28077 -- until there is one item left.
28079 Output
:= First
(Expressions
(Outputs
));
28080 while Present
(Output
) loop
28081 Next_Output
:= Next
(Output
);
28083 -- Unhook the output from the original output list as it
28084 -- will be relocated to a new clause.
28088 -- Special processing for the last output. At this point
28089 -- the original aggregate has been stripped down to one
28090 -- element. Replace the aggregate by the element itself.
28092 if Output
= Last_Output
then
28093 Rewrite
(Outputs
, Output
);
28096 -- Generate a clause of the form:
28097 -- (Output => Inputs)
28100 Make_Component_Association
(Loc
,
28101 Choices
=> New_List
(Output
),
28102 Expression
=> New_Copy_Tree
(Inputs
));
28104 -- The new clause contains replicated content that has
28105 -- already been analyzed. There is not need to reanalyze
28108 Set_Analyzed
(New_Clause
);
28109 Insert_After
(Clause
, New_Clause
);
28112 Output
:= Next_Output
;
28115 end Normalize_Outputs
;
28121 -- Start of processing for Normalize_Clauses
28124 Clause
:= First
(Clauses
);
28125 while Present
(Clause
) loop
28126 Normalize_Outputs
(Clause
);
28130 Clause
:= First
(Clauses
);
28131 while Present
(Clause
) loop
28132 Normalize_Inputs
(Clause
);
28135 end Normalize_Clauses
;
28137 --------------------------
28138 -- Remove_Extra_Clauses --
28139 --------------------------
28141 procedure Remove_Extra_Clauses
28142 (Clauses
: List_Id
;
28143 Matched_Items
: Elist_Id
)
28147 Input_Id
: Entity_Id
;
28148 Next_Clause
: Node_Id
;
28150 State_Id
: Entity_Id
;
28153 Clause
:= First
(Clauses
);
28154 while Present
(Clause
) loop
28155 Next_Clause
:= Next
(Clause
);
28157 Input
:= Expression
(Clause
);
28158 Output
:= First
(Choices
(Clause
));
28160 -- Recognize a clause of the form
28164 -- where Input is a constituent of a state which was already
28165 -- successfully matched. This clause must be removed because it
28166 -- simply indicates that some of the constituents of the state
28169 -- Refined_State => (State => (Constit_1, Constit_2))
28170 -- Depends => (Output => State)
28171 -- Refined_Depends => ((Output => Constit_1), -- State matched
28172 -- (null => Constit_2)) -- OK
28174 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
28176 -- Handle abstract views generated for limited with clauses
28178 Input_Id
:= Available_View
(Entity_Of
(Input
));
28180 -- The input must be a constituent of a state
28182 if Ekind
(Input_Id
) in
28183 E_Abstract_State | E_Constant | E_Variable
28184 and then Present
(Encapsulating_State
(Input_Id
))
28186 State_Id
:= Encapsulating_State
(Input_Id
);
28188 -- The state must have a non-null visible refinement and be
28189 -- matched in a previous clause.
28191 if Has_Non_Null_Visible_Refinement
(State_Id
)
28192 and then Contains
(Matched_Items
, State_Id
)
28198 -- Recognize a clause of the form
28202 -- where Output is an arbitrary item. This clause must be removed
28203 -- because a null input legitimately matches anything.
28205 elsif Nkind
(Input
) = N_Null
then
28209 Clause
:= Next_Clause
;
28211 end Remove_Extra_Clauses
;
28213 --------------------------
28214 -- Report_Extra_Clauses --
28215 --------------------------
28217 procedure Report_Extra_Clauses
(Clauses
: List_Id
) is
28221 -- Do not perform this check in an instance because it was already
28222 -- performed successfully in the generic template.
28224 if In_Instance
then
28227 elsif Present
(Clauses
) then
28228 Clause
:= First
(Clauses
);
28229 while Present
(Clause
) loop
28231 ("unmatched or extra clause in dependence refinement",
28237 end Report_Extra_Clauses
;
28241 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28242 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28243 Errors
: constant Nat
:= Serious_Errors_Detected
;
28250 Body_Inputs
: Elist_Id
:= No_Elist
;
28251 Body_Outputs
: Elist_Id
:= No_Elist
;
28252 -- The inputs and outputs of the subprogram body synthesized from pragma
28253 -- Refined_Depends.
28255 Dependencies
: List_Id
:= No_List
;
28257 -- The corresponding Depends pragma along with its clauses
28259 Matched_Items
: Elist_Id
:= No_Elist
;
28260 -- A list containing the entities of all successfully matched items
28261 -- found in pragma Depends.
28263 Refinements
: List_Id
:= No_List
;
28264 -- The clauses of pragma Refined_Depends
28266 Spec_Id
: Entity_Id
;
28267 -- The entity of the subprogram subject to pragma Refined_Depends
28269 Spec_Inputs
: Elist_Id
:= No_Elist
;
28270 Spec_Outputs
: Elist_Id
:= No_Elist
;
28271 -- The inputs and outputs of the subprogram spec synthesized from pragma
28274 States
: Elist_Id
:= No_Elist
;
28275 -- A list containing the entities of all states whose constituents
28276 -- appear in pragma Depends.
28278 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
28281 -- Do not analyze the pragma multiple times
28283 if Is_Analyzed_Pragma
(N
) then
28287 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28289 -- Use the anonymous object as the proper spec when Refined_Depends
28290 -- applies to the body of a single task type. The object carries the
28291 -- proper Chars as well as all non-refined versions of pragmas.
28293 if Is_Single_Concurrent_Type
(Spec_Id
) then
28294 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28297 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28299 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
28300 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
28302 if No
(Depends
) then
28304 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28305 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
28309 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28311 -- A null dependency relation renders the refinement useless because it
28312 -- cannot possibly mention abstract states with visible refinement. Note
28313 -- that the inverse is not true as states may be refined to null
28314 -- (SPARK RM 7.2.5(2)).
28316 if Nkind
(Deps
) = N_Null
then
28318 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28319 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
28323 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
28324 -- This ensures that the categorization of all refined dependency items
28325 -- is consistent with their role.
28327 Analyze_Depends_In_Decl_Part
(N
);
28329 -- Do not match dependencies against refinements if Refined_Depends is
28330 -- illegal to avoid emitting misleading error.
28332 if Serious_Errors_Detected
= Errors
then
28334 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
28335 -- the inputs and outputs of the subprogram spec and body to verify
28336 -- the use of states with visible refinement and their constituents.
28338 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
28339 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
28341 Collect_Subprogram_Inputs_Outputs
28342 (Subp_Id
=> Spec_Id
,
28343 Synthesize
=> True,
28344 Subp_Inputs
=> Spec_Inputs
,
28345 Subp_Outputs
=> Spec_Outputs
,
28346 Global_Seen
=> Dummy
);
28348 Collect_Subprogram_Inputs_Outputs
28349 (Subp_Id
=> Body_Id
,
28350 Synthesize
=> True,
28351 Subp_Inputs
=> Body_Inputs
,
28352 Subp_Outputs
=> Body_Outputs
,
28353 Global_Seen
=> Dummy
);
28355 -- For an output state with a visible refinement, ensure that all
28356 -- constituents appear as outputs in the dependency refinement.
28358 Check_Output_States
28359 (Spec_Inputs
=> Spec_Inputs
,
28360 Spec_Outputs
=> Spec_Outputs
,
28361 Body_Inputs
=> Body_Inputs
,
28362 Body_Outputs
=> Body_Outputs
);
28365 -- Multiple dependency clauses appear as component associations of an
28366 -- aggregate. Note that the clauses are copied because the algorithm
28367 -- modifies them and this should not be visible in Depends.
28369 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
28370 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
28371 Normalize_Clauses
(Dependencies
);
28373 -- Gather all states which appear in Depends
28375 States
:= Collect_States
(Dependencies
);
28377 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
28379 if Nkind
(Refs
) = N_Null
then
28380 Refinements
:= No_List
;
28382 -- Multiple dependency clauses appear as component associations of an
28383 -- aggregate. Note that the clauses are copied because the algorithm
28384 -- modifies them and this should not be visible in Refined_Depends.
28386 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
28387 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
28388 Normalize_Clauses
(Refinements
);
28391 -- At this point the clauses of pragmas Depends and Refined_Depends
28392 -- have been normalized into simple dependencies between one output
28393 -- and one input. Examine all clauses of pragma Depends looking for
28394 -- matching clauses in pragma Refined_Depends.
28396 Clause
:= First
(Dependencies
);
28397 while Present
(Clause
) loop
28398 Check_Dependency_Clause
28399 (Spec_Id
=> Spec_Id
,
28400 Dep_Clause
=> Clause
,
28401 Dep_States
=> States
,
28402 Refinements
=> Refinements
,
28403 Matched_Items
=> Matched_Items
);
28408 -- Pragma Refined_Depends may contain multiple clarification clauses
28409 -- which indicate that certain constituents do not influence the data
28410 -- flow in any way. Such clauses must be removed as long as the state
28411 -- has been matched, otherwise they will be incorrectly flagged as
28414 -- Refined_State => (State => (Constit_1, Constit_2))
28415 -- Depends => (Output => State)
28416 -- Refined_Depends => ((Output => Constit_1), -- State matched
28417 -- (null => Constit_2)) -- must be removed
28419 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
28421 if Serious_Errors_Detected
= Errors
then
28422 Report_Extra_Clauses
(Refinements
);
28427 Set_Is_Analyzed_Pragma
(N
);
28428 end Analyze_Refined_Depends_In_Decl_Part
;
28430 -----------------------------------------
28431 -- Analyze_Refined_Global_In_Decl_Part --
28432 -----------------------------------------
28434 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
28436 -- The corresponding Global pragma
28438 Has_In_State
: Boolean := False;
28439 Has_In_Out_State
: Boolean := False;
28440 Has_Out_State
: Boolean := False;
28441 Has_Proof_In_State
: Boolean := False;
28442 -- These flags are set when the corresponding Global pragma has a state
28443 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
28446 Has_Null_State
: Boolean := False;
28447 -- This flag is set when the corresponding Global pragma has at least
28448 -- one state with a null refinement.
28450 In_Constits
: Elist_Id
:= No_Elist
;
28451 In_Out_Constits
: Elist_Id
:= No_Elist
;
28452 Out_Constits
: Elist_Id
:= No_Elist
;
28453 Proof_In_Constits
: Elist_Id
:= No_Elist
;
28454 -- These lists contain the entities of all Input, In_Out, Output and
28455 -- Proof_In constituents that appear in Refined_Global and participate
28456 -- in state refinement.
28458 In_Items
: Elist_Id
:= No_Elist
;
28459 In_Out_Items
: Elist_Id
:= No_Elist
;
28460 Out_Items
: Elist_Id
:= No_Elist
;
28461 Proof_In_Items
: Elist_Id
:= No_Elist
;
28462 -- These lists contain the entities of all Input, In_Out, Output and
28463 -- Proof_In items defined in the corresponding Global pragma.
28465 Repeat_Items
: Elist_Id
:= No_Elist
;
28466 -- A list of all global items without full visible refinement found
28467 -- in pragma Global. These states should be repeated in the global
28468 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
28469 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
28471 Spec_Id
: Entity_Id
;
28472 -- The entity of the subprogram subject to pragma Refined_Global
28474 States
: Elist_Id
:= No_Elist
;
28475 -- A list of all states with full or partial visible refinement found in
28478 procedure Check_In_Out_States
;
28479 -- Determine whether the corresponding Global pragma mentions In_Out
28480 -- states with visible refinement and if so, ensure that one of the
28481 -- following completions apply to the constituents of the state:
28482 -- 1) there is at least one constituent of mode In_Out
28483 -- 2) there is at least one Input and one Output constituent
28484 -- 3) not all constituents are present and one of them is of mode
28486 -- This routine may remove elements from In_Constits, In_Out_Constits,
28487 -- Out_Constits and Proof_In_Constits.
28489 procedure Check_Input_States
;
28490 -- Determine whether the corresponding Global pragma mentions Input
28491 -- states with visible refinement and if so, ensure that at least one of
28492 -- its constituents appears as an Input item in Refined_Global.
28493 -- This routine may remove elements from In_Constits, In_Out_Constits,
28494 -- Out_Constits and Proof_In_Constits.
28496 procedure Check_Output_States
;
28497 -- Determine whether the corresponding Global pragma mentions Output
28498 -- states with visible refinement and if so, ensure that all of its
28499 -- constituents appear as Output items in Refined_Global.
28500 -- This routine may remove elements from In_Constits, In_Out_Constits,
28501 -- Out_Constits and Proof_In_Constits.
28503 procedure Check_Proof_In_States
;
28504 -- Determine whether the corresponding Global pragma mentions Proof_In
28505 -- states with visible refinement and if so, ensure that at least one of
28506 -- its constituents appears as a Proof_In item in Refined_Global.
28507 -- This routine may remove elements from In_Constits, In_Out_Constits,
28508 -- Out_Constits and Proof_In_Constits.
28510 procedure Check_Refined_Global_List
28512 Global_Mode
: Name_Id
:= Name_Input
);
28513 -- Verify the legality of a single global list declaration. Global_Mode
28514 -- denotes the current mode in effect.
28516 procedure Collect_Global_Items
28518 Mode
: Name_Id
:= Name_Input
);
28519 -- Gather all Input, In_Out, Output and Proof_In items from node List
28520 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
28521 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
28522 -- and Has_Proof_In_State are set when there is at least one abstract
28523 -- state with full or partial visible refinement available in the
28524 -- corresponding mode. Flag Has_Null_State is set when at least state
28525 -- has a null refinement. Mode denotes the current global mode in
28528 function Present_Then_Remove
28530 Item
: Entity_Id
) return Boolean;
28531 -- Search List for a particular entity Item. If Item has been found,
28532 -- remove it from List. This routine is used to strip lists In_Constits,
28533 -- In_Out_Constits and Out_Constits of valid constituents.
28535 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
28536 -- Same as function Present_Then_Remove, but do not report the presence
28537 -- of Item in List.
28539 procedure Report_Extra_Constituents
;
28540 -- Emit an error for each constituent found in lists In_Constits,
28541 -- In_Out_Constits and Out_Constits.
28543 procedure Report_Missing_Items
;
28544 -- Emit an error for each global item not repeated found in list
28547 -------------------------
28548 -- Check_In_Out_States --
28549 -------------------------
28551 procedure Check_In_Out_States
is
28552 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28553 -- Determine whether one of the following coverage scenarios is in
28555 -- 1) there is at least one constituent of mode In_Out or Output
28556 -- 2) there is at least one pair of constituents with modes Input
28557 -- and Output, or Proof_In and Output.
28558 -- 3) there is at least one constituent of mode Output and not all
28559 -- constituents are present.
28560 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
28562 -----------------------------
28563 -- Check_Constituent_Usage --
28564 -----------------------------
28566 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28567 Constits
: constant Elist_Id
:=
28568 Partial_Refinement_Constituents
(State_Id
);
28569 Constit_Elmt
: Elmt_Id
;
28570 Constit_Id
: Entity_Id
;
28571 Has_Missing
: Boolean := False;
28572 In_Out_Seen
: Boolean := False;
28573 Input_Seen
: Boolean := False;
28574 Output_Seen
: Boolean := False;
28575 Proof_In_Seen
: Boolean := False;
28578 -- Process all the constituents of the state and note their modes
28579 -- within the global refinement.
28581 if Present
(Constits
) then
28582 Constit_Elmt
:= First_Elmt
(Constits
);
28583 while Present
(Constit_Elmt
) loop
28584 Constit_Id
:= Node
(Constit_Elmt
);
28586 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
28587 Input_Seen
:= True;
28589 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
28590 In_Out_Seen
:= True;
28592 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
28593 Output_Seen
:= True;
28595 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28597 Proof_In_Seen
:= True;
28600 Has_Missing
:= True;
28603 Next_Elmt
(Constit_Elmt
);
28607 -- An In_Out constituent is a valid completion
28609 if In_Out_Seen
then
28612 -- A pair of one Input/Proof_In and one Output constituent is a
28613 -- valid completion.
28615 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
28618 elsif Output_Seen
then
28620 -- A single Output constituent is a valid completion only when
28621 -- some of the other constituents are missing.
28623 if Has_Missing
then
28626 -- Otherwise all constituents are of mode Output
28630 ("global refinement of state & must include at least one "
28631 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
28635 -- The state lacks a completion. When full refinement is visible,
28636 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
28637 -- refinement is visible, emit an error if the abstract state
28638 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
28639 -- both are utilized, Check_State_And_Constituent_Use. will issue
28642 elsif not Input_Seen
28643 and then not In_Out_Seen
28644 and then not Output_Seen
28645 and then not Proof_In_Seen
28647 if Has_Visible_Refinement
(State_Id
)
28648 or else Contains
(Repeat_Items
, State_Id
)
28651 ("missing global refinement of state &", N
, State_Id
);
28654 -- Otherwise the state has a malformed completion where at least
28655 -- one of the constituents has a different mode.
28659 ("global refinement of state & redefines the mode of its "
28660 & "constituents", N
, State_Id
);
28662 end Check_Constituent_Usage
;
28666 Item_Elmt
: Elmt_Id
;
28667 Item_Id
: Entity_Id
;
28669 -- Start of processing for Check_In_Out_States
28672 -- Do not perform this check in an instance because it was already
28673 -- performed successfully in the generic template.
28675 if In_Instance
then
28678 -- Inspect the In_Out items of the corresponding Global pragma
28679 -- looking for a state with a visible refinement.
28681 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
28682 Item_Elmt
:= First_Elmt
(In_Out_Items
);
28683 while Present
(Item_Elmt
) loop
28684 Item_Id
:= Node
(Item_Elmt
);
28686 -- Ensure that one of the three coverage variants is satisfied
28688 if Ekind
(Item_Id
) = E_Abstract_State
28689 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28691 Check_Constituent_Usage
(Item_Id
);
28694 Next_Elmt
(Item_Elmt
);
28697 end Check_In_Out_States
;
28699 ------------------------
28700 -- Check_Input_States --
28701 ------------------------
28703 procedure Check_Input_States
is
28704 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28705 -- Determine whether at least one constituent of state State_Id with
28706 -- full or partial visible refinement is used and has mode Input.
28707 -- Ensure that the remaining constituents do not have In_Out or
28708 -- Output modes. Emit an error if this is not the case
28709 -- (SPARK RM 7.2.4(5)).
28711 -----------------------------
28712 -- Check_Constituent_Usage --
28713 -----------------------------
28715 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28716 Constits
: constant Elist_Id
:=
28717 Partial_Refinement_Constituents
(State_Id
);
28718 Constit_Elmt
: Elmt_Id
;
28719 Constit_Id
: Entity_Id
;
28720 In_Seen
: Boolean := False;
28723 if Present
(Constits
) then
28724 Constit_Elmt
:= First_Elmt
(Constits
);
28725 while Present
(Constit_Elmt
) loop
28726 Constit_Id
:= Node
(Constit_Elmt
);
28728 -- At least one of the constituents appears as an Input
28730 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
28733 -- A Proof_In constituent can refine an Input state as long
28734 -- as there is at least one Input constituent present.
28736 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28740 -- The constituent appears in the global refinement, but has
28741 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
28743 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28744 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
28746 Error_Msg_Name_1
:= Chars
(State_Id
);
28748 ("constituent & of state % must have mode `Input` in "
28749 & "global refinement", N
, Constit_Id
);
28752 Next_Elmt
(Constit_Elmt
);
28756 -- Not one of the constituents appeared as Input. Always emit an
28757 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
28758 -- When only partial refinement is visible, emit an error if the
28759 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
28760 -- the case where both are utilized, an error will be issued in
28761 -- Check_State_And_Constituent_Use.
28764 and then (Has_Visible_Refinement
(State_Id
)
28765 or else Contains
(Repeat_Items
, State_Id
))
28768 ("global refinement of state & must include at least one "
28769 & "constituent of mode `Input`", N
, State_Id
);
28771 end Check_Constituent_Usage
;
28775 Item_Elmt
: Elmt_Id
;
28776 Item_Id
: Entity_Id
;
28778 -- Start of processing for Check_Input_States
28781 -- Do not perform this check in an instance because it was already
28782 -- performed successfully in the generic template.
28784 if In_Instance
then
28787 -- Inspect the Input items of the corresponding Global pragma looking
28788 -- for a state with a visible refinement.
28790 elsif Has_In_State
and then Present
(In_Items
) then
28791 Item_Elmt
:= First_Elmt
(In_Items
);
28792 while Present
(Item_Elmt
) loop
28793 Item_Id
:= Node
(Item_Elmt
);
28795 -- When full refinement is visible, ensure that at least one of
28796 -- the constituents is utilized and is of mode Input. When only
28797 -- partial refinement is visible, ensure that either one of
28798 -- the constituents is utilized and is of mode Input, or the
28799 -- abstract state is repeated and no constituent is utilized.
28801 if Ekind
(Item_Id
) = E_Abstract_State
28802 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28804 Check_Constituent_Usage
(Item_Id
);
28807 Next_Elmt
(Item_Elmt
);
28810 end Check_Input_States
;
28812 -------------------------
28813 -- Check_Output_States --
28814 -------------------------
28816 procedure Check_Output_States
is
28817 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28818 -- Determine whether all constituents of state State_Id with full
28819 -- visible refinement are used and have mode Output. Emit an error
28820 -- if this is not the case (SPARK RM 7.2.4(5)).
28822 -----------------------------
28823 -- Check_Constituent_Usage --
28824 -----------------------------
28826 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28827 Constits
: constant Elist_Id
:=
28828 Partial_Refinement_Constituents
(State_Id
);
28829 Only_Partial
: constant Boolean :=
28830 not Has_Visible_Refinement
(State_Id
);
28831 Constit_Elmt
: Elmt_Id
;
28832 Constit_Id
: Entity_Id
;
28833 Posted
: Boolean := False;
28836 if Present
(Constits
) then
28837 Constit_Elmt
:= First_Elmt
(Constits
);
28838 while Present
(Constit_Elmt
) loop
28839 Constit_Id
:= Node
(Constit_Elmt
);
28841 -- Issue an error when a constituent of State_Id is utilized
28842 -- and State_Id has only partial visible refinement
28843 -- (SPARK RM 7.2.4(3d)).
28845 if Only_Partial
then
28846 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
28847 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
28849 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28851 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28853 Error_Msg_Name_1
:= Chars
(State_Id
);
28855 ("constituent & of state % cannot be used in global "
28856 & "refinement", N
, Constit_Id
);
28857 Error_Msg_Name_1
:= Chars
(State_Id
);
28858 SPARK_Msg_N
("\use state % instead", N
);
28861 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
28864 -- The constituent appears in the global refinement, but has
28865 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
28867 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
28868 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28869 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28871 Error_Msg_Name_1
:= Chars
(State_Id
);
28873 ("constituent & of state % must have mode `Output` in "
28874 & "global refinement", N
, Constit_Id
);
28876 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
28882 ("`Output` state & must be replaced by all its "
28883 & "constituents in global refinement", N
, State_Id
);
28887 ("\constituent & is missing in output list",
28891 Next_Elmt
(Constit_Elmt
);
28894 end Check_Constituent_Usage
;
28898 Item_Elmt
: Elmt_Id
;
28899 Item_Id
: Entity_Id
;
28901 -- Start of processing for Check_Output_States
28904 -- Do not perform this check in an instance because it was already
28905 -- performed successfully in the generic template.
28907 if In_Instance
then
28910 -- Inspect the Output items of the corresponding Global pragma
28911 -- looking for a state with a visible refinement.
28913 elsif Has_Out_State
and then Present
(Out_Items
) then
28914 Item_Elmt
:= First_Elmt
(Out_Items
);
28915 while Present
(Item_Elmt
) loop
28916 Item_Id
:= Node
(Item_Elmt
);
28918 -- When full refinement is visible, ensure that all of the
28919 -- constituents are utilized and they have mode Output. When
28920 -- only partial refinement is visible, ensure that no
28921 -- constituent is utilized.
28923 if Ekind
(Item_Id
) = E_Abstract_State
28924 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28926 Check_Constituent_Usage
(Item_Id
);
28929 Next_Elmt
(Item_Elmt
);
28932 end Check_Output_States
;
28934 ---------------------------
28935 -- Check_Proof_In_States --
28936 ---------------------------
28938 procedure Check_Proof_In_States
is
28939 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28940 -- Determine whether at least one constituent of state State_Id with
28941 -- full or partial visible refinement is used and has mode Proof_In.
28942 -- Ensure that the remaining constituents do not have Input, In_Out,
28943 -- or Output modes. Emit an error if this is not the case
28944 -- (SPARK RM 7.2.4(5)).
28946 -----------------------------
28947 -- Check_Constituent_Usage --
28948 -----------------------------
28950 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28951 Constits
: constant Elist_Id
:=
28952 Partial_Refinement_Constituents
(State_Id
);
28953 Constit_Elmt
: Elmt_Id
;
28954 Constit_Id
: Entity_Id
;
28955 Proof_In_Seen
: Boolean := False;
28958 if Present
(Constits
) then
28959 Constit_Elmt
:= First_Elmt
(Constits
);
28960 while Present
(Constit_Elmt
) loop
28961 Constit_Id
:= Node
(Constit_Elmt
);
28963 -- At least one of the constituents appears as Proof_In
28965 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
28966 Proof_In_Seen
:= True;
28968 -- The constituent appears in the global refinement, but has
28969 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
28971 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
28972 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28973 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
28975 Error_Msg_Name_1
:= Chars
(State_Id
);
28977 ("constituent & of state % must have mode `Proof_In` "
28978 & "in global refinement", N
, Constit_Id
);
28981 Next_Elmt
(Constit_Elmt
);
28985 -- Not one of the constituents appeared as Proof_In. Always emit
28986 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
28987 -- When only partial refinement is visible, emit an error if the
28988 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
28989 -- the case where both are utilized, an error will be issued by
28990 -- Check_State_And_Constituent_Use.
28992 if not Proof_In_Seen
28993 and then (Has_Visible_Refinement
(State_Id
)
28994 or else Contains
(Repeat_Items
, State_Id
))
28997 ("global refinement of state & must include at least one "
28998 & "constituent of mode `Proof_In`", N
, State_Id
);
29000 end Check_Constituent_Usage
;
29004 Item_Elmt
: Elmt_Id
;
29005 Item_Id
: Entity_Id
;
29007 -- Start of processing for Check_Proof_In_States
29010 -- Do not perform this check in an instance because it was already
29011 -- performed successfully in the generic template.
29013 if In_Instance
then
29016 -- Inspect the Proof_In items of the corresponding Global pragma
29017 -- looking for a state with a visible refinement.
29019 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
29020 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
29021 while Present
(Item_Elmt
) loop
29022 Item_Id
:= Node
(Item_Elmt
);
29024 -- Ensure that at least one of the constituents is utilized
29025 -- and is of mode Proof_In. When only partial refinement is
29026 -- visible, ensure that either one of the constituents is
29027 -- utilized and is of mode Proof_In, or the abstract state
29028 -- is repeated and no constituent is utilized.
29030 if Ekind
(Item_Id
) = E_Abstract_State
29031 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
29033 Check_Constituent_Usage
(Item_Id
);
29036 Next_Elmt
(Item_Elmt
);
29039 end Check_Proof_In_States
;
29041 -------------------------------
29042 -- Check_Refined_Global_List --
29043 -------------------------------
29045 procedure Check_Refined_Global_List
29047 Global_Mode
: Name_Id
:= Name_Input
)
29049 procedure Check_Refined_Global_Item
29051 Global_Mode
: Name_Id
);
29052 -- Verify the legality of a single global item declaration. Parameter
29053 -- Global_Mode denotes the current mode in effect.
29055 -------------------------------
29056 -- Check_Refined_Global_Item --
29057 -------------------------------
29059 procedure Check_Refined_Global_Item
29061 Global_Mode
: Name_Id
)
29063 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
29065 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
29066 -- Issue a common error message for all mode mismatches. Expect
29067 -- denotes the expected mode.
29069 -----------------------------
29070 -- Inconsistent_Mode_Error --
29071 -----------------------------
29073 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
29076 ("global item & has inconsistent modes", Item
, Item_Id
);
29078 Error_Msg_Name_1
:= Global_Mode
;
29079 Error_Msg_Name_2
:= Expect
;
29080 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
29081 end Inconsistent_Mode_Error
;
29085 Enc_State
: Entity_Id
:= Empty
;
29086 -- Encapsulating state for constituent, Empty otherwise
29088 -- Start of processing for Check_Refined_Global_Item
29091 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
29093 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
29096 -- When the state or object acts as a constituent of another
29097 -- state with a visible refinement, collect it for the state
29098 -- completeness checks performed later on. Note that the item
29099 -- acts as a constituent only when the encapsulating state is
29100 -- present in pragma Global.
29102 if Present
(Enc_State
)
29103 and then (Has_Visible_Refinement
(Enc_State
)
29104 or else Has_Partial_Visible_Refinement
(Enc_State
))
29105 and then Contains
(States
, Enc_State
)
29107 -- If the state has only partial visible refinement, remove it
29108 -- from the list of items that should be repeated from pragma
29111 if not Has_Visible_Refinement
(Enc_State
) then
29112 Present_Then_Remove
(Repeat_Items
, Enc_State
);
29115 if Global_Mode
= Name_Input
then
29116 Append_New_Elmt
(Item_Id
, In_Constits
);
29118 elsif Global_Mode
= Name_In_Out
then
29119 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
29121 elsif Global_Mode
= Name_Output
then
29122 Append_New_Elmt
(Item_Id
, Out_Constits
);
29124 elsif Global_Mode
= Name_Proof_In
then
29125 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
29128 -- When not a constituent, ensure that both occurrences of the
29129 -- item in pragmas Global and Refined_Global match. Also remove
29130 -- it when present from the list of items that should be repeated
29131 -- from pragma Global.
29134 Present_Then_Remove
(Repeat_Items
, Item_Id
);
29136 if Contains
(In_Items
, Item_Id
) then
29137 if Global_Mode
/= Name_Input
then
29138 Inconsistent_Mode_Error
(Name_Input
);
29141 elsif Contains
(In_Out_Items
, Item_Id
) then
29142 if Global_Mode
/= Name_In_Out
then
29143 Inconsistent_Mode_Error
(Name_In_Out
);
29146 elsif Contains
(Out_Items
, Item_Id
) then
29147 if Global_Mode
/= Name_Output
then
29148 Inconsistent_Mode_Error
(Name_Output
);
29151 elsif Contains
(Proof_In_Items
, Item_Id
) then
29154 -- The item does not appear in the corresponding Global pragma,
29155 -- it must be an extra (SPARK RM 7.2.4(3)).
29158 pragma Assert
(Present
(Global
));
29159 Error_Msg_Sloc
:= Sloc
(Global
);
29161 ("extra global item & does not refine or repeat any "
29162 & "global item #", Item
, Item_Id
);
29165 end Check_Refined_Global_Item
;
29171 -- Start of processing for Check_Refined_Global_List
29174 -- Do not perform this check in an instance because it was already
29175 -- performed successfully in the generic template.
29177 if In_Instance
then
29180 elsif Nkind
(List
) = N_Null
then
29183 -- Single global item declaration
29185 elsif Nkind
(List
) in N_Expanded_Name
29187 | N_Selected_Component
29189 Check_Refined_Global_Item
(List
, Global_Mode
);
29191 -- Simple global list or moded global list declaration
29193 elsif Nkind
(List
) = N_Aggregate
then
29195 -- The declaration of a simple global list appear as a collection
29198 if Present
(Expressions
(List
)) then
29199 Item
:= First
(Expressions
(List
));
29200 while Present
(Item
) loop
29201 Check_Refined_Global_Item
(Item
, Global_Mode
);
29205 -- The declaration of a moded global list appears as a collection
29206 -- of component associations where individual choices denote
29209 elsif Present
(Component_Associations
(List
)) then
29210 Item
:= First
(Component_Associations
(List
));
29211 while Present
(Item
) loop
29212 Check_Refined_Global_List
29213 (List
=> Expression
(Item
),
29214 Global_Mode
=> Chars
(First
(Choices
(Item
))));
29222 raise Program_Error
;
29228 raise Program_Error
;
29230 end Check_Refined_Global_List
;
29232 --------------------------
29233 -- Collect_Global_Items --
29234 --------------------------
29236 procedure Collect_Global_Items
29238 Mode
: Name_Id
:= Name_Input
)
29240 procedure Collect_Global_Item
29242 Item_Mode
: Name_Id
);
29243 -- Add a single item to the appropriate list. Item_Mode denotes the
29244 -- current mode in effect.
29246 -------------------------
29247 -- Collect_Global_Item --
29248 -------------------------
29250 procedure Collect_Global_Item
29252 Item_Mode
: Name_Id
)
29254 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
29255 -- The above handles abstract views of variables and states built
29256 -- for limited with clauses.
29259 -- Signal that the global list contains at least one abstract
29260 -- state with a visible refinement. Note that the refinement may
29261 -- be null in which case there are no constituents.
29263 if Ekind
(Item_Id
) = E_Abstract_State
then
29264 if Has_Null_Visible_Refinement
(Item_Id
) then
29265 Has_Null_State
:= True;
29267 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
29268 Append_New_Elmt
(Item_Id
, States
);
29270 if Item_Mode
= Name_Input
then
29271 Has_In_State
:= True;
29272 elsif Item_Mode
= Name_In_Out
then
29273 Has_In_Out_State
:= True;
29274 elsif Item_Mode
= Name_Output
then
29275 Has_Out_State
:= True;
29276 elsif Item_Mode
= Name_Proof_In
then
29277 Has_Proof_In_State
:= True;
29282 -- Record global items without full visible refinement found in
29283 -- pragma Global which should be repeated in the global refinement
29284 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
29286 if Ekind
(Item_Id
) /= E_Abstract_State
29287 or else not Has_Visible_Refinement
(Item_Id
)
29289 Append_New_Elmt
(Item_Id
, Repeat_Items
);
29292 -- Add the item to the proper list
29294 if Item_Mode
= Name_Input
then
29295 Append_New_Elmt
(Item_Id
, In_Items
);
29296 elsif Item_Mode
= Name_In_Out
then
29297 Append_New_Elmt
(Item_Id
, In_Out_Items
);
29298 elsif Item_Mode
= Name_Output
then
29299 Append_New_Elmt
(Item_Id
, Out_Items
);
29300 elsif Item_Mode
= Name_Proof_In
then
29301 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
29303 end Collect_Global_Item
;
29309 -- Start of processing for Collect_Global_Items
29312 if Nkind
(List
) = N_Null
then
29315 -- Single global item declaration
29317 elsif Nkind
(List
) in N_Expanded_Name
29319 | N_Selected_Component
29321 Collect_Global_Item
(List
, Mode
);
29323 -- Single global list or moded global list declaration
29325 elsif Nkind
(List
) = N_Aggregate
then
29327 -- The declaration of a simple global list appear as a collection
29330 if Present
(Expressions
(List
)) then
29331 Item
:= First
(Expressions
(List
));
29332 while Present
(Item
) loop
29333 Collect_Global_Item
(Item
, Mode
);
29337 -- The declaration of a moded global list appears as a collection
29338 -- of component associations where individual choices denote mode.
29340 elsif Present
(Component_Associations
(List
)) then
29341 Item
:= First
(Component_Associations
(List
));
29342 while Present
(Item
) loop
29343 Collect_Global_Items
29344 (List
=> Expression
(Item
),
29345 Mode
=> Chars
(First
(Choices
(Item
))));
29353 raise Program_Error
;
29356 -- To accommodate partial decoration of disabled SPARK features, this
29357 -- routine may be called with illegal input. If this is the case, do
29358 -- not raise Program_Error.
29363 end Collect_Global_Items
;
29365 -------------------------
29366 -- Present_Then_Remove --
29367 -------------------------
29369 function Present_Then_Remove
29371 Item
: Entity_Id
) return Boolean
29376 if Present
(List
) then
29377 Elmt
:= First_Elmt
(List
);
29378 while Present
(Elmt
) loop
29379 if Node
(Elmt
) = Item
then
29380 Remove_Elmt
(List
, Elmt
);
29389 end Present_Then_Remove
;
29391 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
29394 Ignore
:= Present_Then_Remove
(List
, Item
);
29395 end Present_Then_Remove
;
29397 -------------------------------
29398 -- Report_Extra_Constituents --
29399 -------------------------------
29401 procedure Report_Extra_Constituents
is
29402 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
29403 -- Emit an error for every element of List
29405 ---------------------------------------
29406 -- Report_Extra_Constituents_In_List --
29407 ---------------------------------------
29409 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
29410 Constit_Elmt
: Elmt_Id
;
29413 if Present
(List
) then
29414 Constit_Elmt
:= First_Elmt
(List
);
29415 while Present
(Constit_Elmt
) loop
29416 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
29417 Next_Elmt
(Constit_Elmt
);
29420 end Report_Extra_Constituents_In_List
;
29422 -- Start of processing for Report_Extra_Constituents
29425 -- Do not perform this check in an instance because it was already
29426 -- performed successfully in the generic template.
29428 if In_Instance
then
29432 Report_Extra_Constituents_In_List
(In_Constits
);
29433 Report_Extra_Constituents_In_List
(In_Out_Constits
);
29434 Report_Extra_Constituents_In_List
(Out_Constits
);
29435 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
29437 end Report_Extra_Constituents
;
29439 --------------------------
29440 -- Report_Missing_Items --
29441 --------------------------
29443 procedure Report_Missing_Items
is
29444 Item_Elmt
: Elmt_Id
;
29445 Item_Id
: Entity_Id
;
29448 -- Do not perform this check in an instance because it was already
29449 -- performed successfully in the generic template.
29451 if In_Instance
then
29455 if Present
(Repeat_Items
) then
29456 Item_Elmt
:= First_Elmt
(Repeat_Items
);
29457 while Present
(Item_Elmt
) loop
29458 Item_Id
:= Node
(Item_Elmt
);
29459 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
29460 Next_Elmt
(Item_Elmt
);
29464 end Report_Missing_Items
;
29468 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29469 Errors
: constant Nat
:= Serious_Errors_Detected
;
29471 No_Constit
: Boolean;
29473 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
29476 -- Do not analyze the pragma multiple times
29478 if Is_Analyzed_Pragma
(N
) then
29482 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
29484 -- Use the anonymous object as the proper spec when Refined_Global
29485 -- applies to the body of a single task type. The object carries the
29486 -- proper Chars as well as all non-refined versions of pragmas.
29488 if Is_Single_Concurrent_Type
(Spec_Id
) then
29489 Spec_Id
:= Anonymous_Object
(Spec_Id
);
29492 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
29493 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
29495 -- The subprogram declaration lacks pragma Global. This renders
29496 -- Refined_Global useless as there is nothing to refine.
29498 if No
(Global
) then
29500 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
29501 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
29505 -- Extract all relevant items from the corresponding Global pragma
29507 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
29509 -- Package and subprogram bodies are instantiated individually in
29510 -- a separate compiler pass. Due to this mode of instantiation, the
29511 -- refinement of a state may no longer be visible when a subprogram
29512 -- body contract is instantiated. Since the generic template is legal,
29513 -- do not perform this check in the instance to circumvent this oddity.
29515 if In_Instance
then
29518 -- Non-instance case
29521 -- The corresponding Global pragma must mention at least one
29522 -- state with a visible refinement at the point Refined_Global
29523 -- is processed. States with null refinements need Refined_Global
29524 -- pragma (SPARK RM 7.2.4(2)).
29526 if not Has_In_State
29527 and then not Has_In_Out_State
29528 and then not Has_Out_State
29529 and then not Has_Proof_In_State
29530 and then not Has_Null_State
29533 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
29534 & "depend on abstract state with visible refinement"),
29538 -- The global refinement of inputs and outputs cannot be null when
29539 -- the corresponding Global pragma contains at least one item except
29540 -- in the case where we have states with null refinements.
29542 elsif Nkind
(Items
) = N_Null
29544 (Present
(In_Items
)
29545 or else Present
(In_Out_Items
)
29546 or else Present
(Out_Items
)
29547 or else Present
(Proof_In_Items
))
29548 and then not Has_Null_State
29551 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
29552 & "global items"), N
, Spec_Id
);
29557 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
29558 -- This ensures that the categorization of all refined global items is
29559 -- consistent with their role.
29561 Analyze_Global_In_Decl_Part
(N
);
29563 -- Perform all refinement checks with respect to completeness and mode
29566 if Serious_Errors_Detected
= Errors
then
29567 Check_Refined_Global_List
(Items
);
29570 -- Store the information that no constituent is used in the global
29571 -- refinement, prior to calling checking procedures which remove items
29572 -- from the list of constituents.
29576 and then No
(In_Out_Constits
)
29577 and then No
(Out_Constits
)
29578 and then No
(Proof_In_Constits
);
29580 -- For Input states with visible refinement, at least one constituent
29581 -- must be used as an Input in the global refinement.
29583 if Serious_Errors_Detected
= Errors
then
29584 Check_Input_States
;
29587 -- Verify all possible completion variants for In_Out states with
29588 -- visible refinement.
29590 if Serious_Errors_Detected
= Errors
then
29591 Check_In_Out_States
;
29594 -- For Output states with visible refinement, all constituents must be
29595 -- used as Outputs in the global refinement.
29597 if Serious_Errors_Detected
= Errors
then
29598 Check_Output_States
;
29601 -- For Proof_In states with visible refinement, at least one constituent
29602 -- must be used as Proof_In in the global refinement.
29604 if Serious_Errors_Detected
= Errors
then
29605 Check_Proof_In_States
;
29608 -- Emit errors for all constituents that belong to other states with
29609 -- visible refinement that do not appear in Global.
29611 if Serious_Errors_Detected
= Errors
then
29612 Report_Extra_Constituents
;
29615 -- Emit errors for all items in Global that are not repeated in the
29616 -- global refinement and for which there is no full visible refinement
29617 -- and, in the case of states with partial visible refinement, no
29618 -- constituent is mentioned in the global refinement.
29620 if Serious_Errors_Detected
= Errors
then
29621 Report_Missing_Items
;
29624 -- Emit an error if no constituent is used in the global refinement
29625 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
29626 -- one may be issued by the checking procedures. Do not perform this
29627 -- check in an instance because it was already performed successfully
29628 -- in the generic template.
29630 if Serious_Errors_Detected
= Errors
29631 and then not In_Instance
29632 and then not Has_Null_State
29633 and then No_Constit
29635 SPARK_Msg_N
("missing refinement", N
);
29639 Set_Is_Analyzed_Pragma
(N
);
29640 end Analyze_Refined_Global_In_Decl_Part
;
29642 ----------------------------------------
29643 -- Analyze_Refined_State_In_Decl_Part --
29644 ----------------------------------------
29646 procedure Analyze_Refined_State_In_Decl_Part
29648 Freeze_Id
: Entity_Id
:= Empty
)
29650 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
29651 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
29652 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
29654 Available_States
: Elist_Id
:= No_Elist
;
29655 -- A list of all abstract states defined in the package declaration that
29656 -- are available for refinement. The list is used to report unrefined
29659 Body_States
: Elist_Id
:= No_Elist
;
29660 -- A list of all hidden states that appear in the body of the related
29661 -- package. The list is used to report unused hidden states.
29663 Constituents_Seen
: Elist_Id
:= No_Elist
;
29664 -- A list that contains all constituents processed so far. The list is
29665 -- used to detect multiple uses of the same constituent.
29667 Freeze_Posted
: Boolean := False;
29668 -- A flag that controls the output of a freezing-related error (see use
29671 Refined_States_Seen
: Elist_Id
:= No_Elist
;
29672 -- A list that contains all refined states processed so far. The list is
29673 -- used to detect duplicate refinements.
29675 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
29676 -- Perform full analysis of a single refinement clause
29678 procedure Report_Unrefined_States
(States
: Elist_Id
);
29679 -- Emit errors for all unrefined abstract states found in list States
29681 -------------------------------
29682 -- Analyze_Refinement_Clause --
29683 -------------------------------
29685 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
29686 AR_Constit
: Entity_Id
:= Empty
;
29687 AW_Constit
: Entity_Id
:= Empty
;
29688 ER_Constit
: Entity_Id
:= Empty
;
29689 EW_Constit
: Entity_Id
:= Empty
;
29690 -- The entities of external constituents that contain one of the
29691 -- following enabled properties: Async_Readers, Async_Writers,
29692 -- Effective_Reads and Effective_Writes.
29694 External_Constit_Seen
: Boolean := False;
29695 -- Flag used to mark when at least one external constituent is part
29696 -- of the state refinement.
29698 Non_Null_Seen
: Boolean := False;
29699 Null_Seen
: Boolean := False;
29700 -- Flags used to detect multiple uses of null in a single clause or a
29701 -- mixture of null and non-null constituents.
29703 Part_Of_Constits
: Elist_Id
:= No_Elist
;
29704 -- A list of all candidate constituents subject to indicator Part_Of
29705 -- where the encapsulating state is the current state.
29708 State_Id
: Entity_Id
;
29709 -- The current state being refined
29711 procedure Analyze_Constituent
(Constit
: Node_Id
);
29712 -- Perform full analysis of a single constituent
29714 procedure Check_External_Property
29715 (Prop_Nam
: Name_Id
;
29717 Constit
: Entity_Id
);
29718 -- Determine whether a property denoted by name Prop_Nam is present
29719 -- in the refined state. Emit an error if this is not the case. Flag
29720 -- Enabled should be set when the property applies to the refined
29721 -- state. Constit denotes the constituent (if any) which introduces
29722 -- the property in the refinement.
29724 procedure Match_State
;
29725 -- Determine whether the state being refined appears in list
29726 -- Available_States. Emit an error when attempting to re-refine the
29727 -- state or when the state is not defined in the package declaration,
29728 -- otherwise remove the state from Available_States.
29730 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
29731 -- Emit errors for all unused Part_Of constituents in list Constits
29733 -------------------------
29734 -- Analyze_Constituent --
29735 -------------------------
29737 procedure Analyze_Constituent
(Constit
: Node_Id
) is
29738 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
29739 -- Determine whether constituent Constit denoted by its entity
29740 -- Constit_Id appears in Body_States. Emit an error when the
29741 -- constituent is not a valid hidden state of the related package
29742 -- or when it is used more than once. Otherwise remove the
29743 -- constituent from Body_States.
29745 -----------------------
29746 -- Match_Constituent --
29747 -----------------------
29749 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
29750 procedure Collect_Constituent
;
29751 -- Verify the legality of constituent Constit_Id and add it to
29752 -- the refinements of State_Id.
29754 -------------------------
29755 -- Collect_Constituent --
29756 -------------------------
29758 procedure Collect_Constituent
is
29759 Constits
: Elist_Id
;
29762 -- The Ghost policy in effect at the point of abstract state
29763 -- declaration and constituent must match (SPARK RM 6.9(15))
29765 Check_Ghost_Refinement
29766 (State
, State_Id
, Constit
, Constit_Id
);
29768 -- A synchronized state must be refined by a synchronized
29769 -- object or another synchronized state (SPARK RM 9.6).
29771 if Is_Synchronized_State
(State_Id
)
29772 and then not Is_Synchronized_Object
(Constit_Id
)
29773 and then not Is_Synchronized_State
(Constit_Id
)
29776 ("constituent of synchronized state & must be "
29777 & "synchronized", Constit
, State_Id
);
29780 -- Add the constituent to the list of processed items to aid
29781 -- with the detection of duplicates.
29783 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
29785 -- Collect the constituent in the list of refinement items
29786 -- and establish a relation between the refined state and
29789 Constits
:= Refinement_Constituents
(State_Id
);
29791 if No
(Constits
) then
29792 Constits
:= New_Elmt_List
;
29793 Set_Refinement_Constituents
(State_Id
, Constits
);
29796 Append_Elmt
(Constit_Id
, Constits
);
29797 Set_Encapsulating_State
(Constit_Id
, State_Id
);
29799 -- The state has at least one legal constituent, mark the
29800 -- start of the refinement region. The region ends when the
29801 -- body declarations end (see routine Analyze_Declarations).
29803 Set_Has_Visible_Refinement
(State_Id
);
29805 -- When the constituent is external, save its relevant
29806 -- property for further checks.
29808 if Async_Readers_Enabled
(Constit_Id
) then
29809 AR_Constit
:= Constit_Id
;
29810 External_Constit_Seen
:= True;
29813 if Async_Writers_Enabled
(Constit_Id
) then
29814 AW_Constit
:= Constit_Id
;
29815 External_Constit_Seen
:= True;
29818 if Effective_Reads_Enabled
(Constit_Id
) then
29819 ER_Constit
:= Constit_Id
;
29820 External_Constit_Seen
:= True;
29823 if Effective_Writes_Enabled
(Constit_Id
) then
29824 EW_Constit
:= Constit_Id
;
29825 External_Constit_Seen
:= True;
29827 end Collect_Constituent
;
29831 State_Elmt
: Elmt_Id
;
29833 -- Start of processing for Match_Constituent
29836 -- Detect a duplicate use of a constituent
29838 if Contains
(Constituents_Seen
, Constit_Id
) then
29840 ("duplicate use of constituent &", Constit
, Constit_Id
);
29844 -- The constituent is subject to a Part_Of indicator
29846 if Present
(Encapsulating_State
(Constit_Id
)) then
29847 if Encapsulating_State
(Constit_Id
) = State_Id
then
29848 Remove
(Part_Of_Constits
, Constit_Id
);
29849 Collect_Constituent
;
29851 -- The constituent is part of another state and is used
29852 -- incorrectly in the refinement of the current state.
29855 Error_Msg_Name_1
:= Chars
(State_Id
);
29857 ("& cannot act as constituent of state %",
29858 Constit
, Constit_Id
);
29860 ("\Part_Of indicator specifies encapsulator &",
29861 Constit
, Encapsulating_State
(Constit_Id
));
29866 Pack_Id
: Entity_Id
;
29867 Placement
: State_Space_Kind
;
29869 -- Find where the constituent lives with respect to the
29872 Find_Placement_In_State_Space
29873 (Item_Id
=> Constit_Id
,
29874 Placement
=> Placement
,
29875 Pack_Id
=> Pack_Id
);
29877 -- The constituent is either part of the hidden state of
29878 -- the package or part of the visible state of a private
29879 -- child package, but lacks a Part_Of indicator.
29881 if (Placement
= Private_State_Space
29882 and then Pack_Id
= Spec_Id
)
29884 (Placement
= Visible_State_Space
29885 and then Is_Child_Unit
(Pack_Id
)
29886 and then not Is_Generic_Unit
(Pack_Id
)
29887 and then Is_Private_Descendant
(Pack_Id
))
29889 Error_Msg_Name_1
:= Chars
(State_Id
);
29891 ("& cannot act as constituent of state %",
29892 Constit
, Constit_Id
);
29894 Sloc
(Enclosing_Declaration
(Constit_Id
));
29896 ("\missing Part_Of indicator # should specify "
29897 & "encapsulator &",
29898 Constit
, State_Id
);
29900 -- The only other source of legal constituents is the
29901 -- body state space of the related package.
29904 if Present
(Body_States
) then
29905 State_Elmt
:= First_Elmt
(Body_States
);
29906 while Present
(State_Elmt
) loop
29908 -- Consume a valid constituent to signal that it
29909 -- has been encountered.
29911 if Node
(State_Elmt
) = Constit_Id
then
29912 Remove_Elmt
(Body_States
, State_Elmt
);
29913 Collect_Constituent
;
29917 Next_Elmt
(State_Elmt
);
29921 -- At this point it is known that the constituent is
29922 -- not part of the package hidden state and cannot be
29923 -- used in a refinement (SPARK RM 7.2.2(9)).
29925 Error_Msg_Name_1
:= Chars
(Spec_Id
);
29927 ("cannot use & in refinement, constituent is not a "
29928 & "hidden state of package %", Constit
, Constit_Id
);
29932 end Match_Constituent
;
29936 Constit_Id
: Entity_Id
;
29937 Constits
: Elist_Id
;
29939 -- Start of processing for Analyze_Constituent
29942 -- Detect multiple uses of null in a single refinement clause or a
29943 -- mixture of null and non-null constituents.
29945 if Nkind
(Constit
) = N_Null
then
29948 ("multiple null constituents not allowed", Constit
);
29950 elsif Non_Null_Seen
then
29952 ("cannot mix null and non-null constituents", Constit
);
29957 -- Collect the constituent in the list of refinement items
29959 Constits
:= Refinement_Constituents
(State_Id
);
29961 if No
(Constits
) then
29962 Constits
:= New_Elmt_List
;
29963 Set_Refinement_Constituents
(State_Id
, Constits
);
29966 Append_Elmt
(Constit
, Constits
);
29968 -- The state has at least one legal constituent, mark the
29969 -- start of the refinement region. The region ends when the
29970 -- body declarations end (see Analyze_Declarations).
29972 Set_Has_Visible_Refinement
(State_Id
);
29975 -- Non-null constituents
29978 Non_Null_Seen
:= True;
29982 ("cannot mix null and non-null constituents", Constit
);
29986 Resolve_State
(Constit
);
29988 -- Ensure that the constituent denotes a valid state or a
29989 -- whole object (SPARK RM 7.2.2(5)).
29991 if Is_Entity_Name
(Constit
) then
29992 Constit_Id
:= Entity_Of
(Constit
);
29994 -- When a constituent is declared after a subprogram body
29995 -- that caused freezing of the related contract where
29996 -- pragma Refined_State resides, the constituent appears
29997 -- undefined and carries Any_Id as its entity.
29999 -- package body Pack
30000 -- with Refined_State => (State => Constit)
30003 -- with Refined_Global => (Input => Constit)
30011 if Constit_Id
= Any_Id
then
30012 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
30014 -- Emit a specialized info message when the contract of
30015 -- the related package body was "frozen" by another body.
30016 -- Note that it is not possible to precisely identify why
30017 -- the constituent is undefined because it is not visible
30018 -- when pragma Refined_State is analyzed. This message is
30019 -- a reasonable approximation.
30021 if Present
(Freeze_Id
) and then not Freeze_Posted
then
30022 Freeze_Posted
:= True;
30024 Error_Msg_Name_1
:= Chars
(Body_Id
);
30025 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30027 ("body & declared # freezes the contract of %",
30030 ("\all constituents must be declared before body #",
30033 -- A misplaced constituent is a critical error because
30034 -- pragma Refined_Depends or Refined_Global depends on
30035 -- the proper link between a state and a constituent.
30036 -- Stop the compilation, as this leads to a multitude
30037 -- of misleading cascaded errors.
30039 raise Unrecoverable_Error
;
30042 -- The constituent is a valid state or object
30044 elsif Ekind
(Constit_Id
) in
30045 E_Abstract_State | E_Constant | E_Variable
30047 Match_Constituent
(Constit_Id
);
30049 -- The variable may eventually become a constituent of a
30050 -- single protected/task type. Record the reference now
30051 -- and verify its legality when analyzing the contract of
30052 -- the variable (SPARK RM 9.3).
30054 if Ekind
(Constit_Id
) = E_Variable
then
30055 Record_Possible_Part_Of_Reference
30056 (Var_Id
=> Constit_Id
,
30060 -- Otherwise the constituent is illegal
30064 ("constituent & must denote object or state",
30065 Constit
, Constit_Id
);
30068 -- The constituent is illegal
30071 SPARK_Msg_N
("malformed constituent", Constit
);
30074 end Analyze_Constituent
;
30076 -----------------------------
30077 -- Check_External_Property --
30078 -----------------------------
30080 procedure Check_External_Property
30081 (Prop_Nam
: Name_Id
;
30083 Constit
: Entity_Id
)
30086 -- The property is missing in the declaration of the state, but
30087 -- a constituent is introducing it in the state refinement
30088 -- (SPARK RM 7.2.8(2)).
30090 if not Enabled
and then Present
(Constit
) then
30091 Error_Msg_Name_1
:= Prop_Nam
;
30092 Error_Msg_Name_2
:= Chars
(State_Id
);
30094 ("constituent & introduces external property % in refinement "
30095 & "of state %", State
, Constit
);
30097 Error_Msg_Sloc
:= Sloc
(State_Id
);
30099 ("\property is missing in abstract state declaration #",
30102 end Check_External_Property
;
30108 procedure Match_State
is
30109 State_Elmt
: Elmt_Id
;
30112 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
30114 if Contains
(Refined_States_Seen
, State_Id
) then
30116 ("duplicate refinement of state &", State
, State_Id
);
30120 -- Inspect the abstract states defined in the package declaration
30121 -- looking for a match.
30123 State_Elmt
:= First_Elmt
(Available_States
);
30124 while Present
(State_Elmt
) loop
30126 -- A valid abstract state is being refined in the body. Add
30127 -- the state to the list of processed refined states to aid
30128 -- with the detection of duplicate refinements. Remove the
30129 -- state from Available_States to signal that it has already
30132 if Node
(State_Elmt
) = State_Id
then
30133 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
30134 Remove_Elmt
(Available_States
, State_Elmt
);
30138 Next_Elmt
(State_Elmt
);
30141 -- If we get here, we are refining a state that is not defined in
30142 -- the package declaration.
30144 Error_Msg_Name_1
:= Chars
(Spec_Id
);
30146 ("cannot refine state, & is not defined in package %",
30150 --------------------------------
30151 -- Report_Unused_Constituents --
30152 --------------------------------
30154 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
30155 Constit_Elmt
: Elmt_Id
;
30156 Constit_Id
: Entity_Id
;
30157 Posted
: Boolean := False;
30160 if Present
(Constits
) then
30161 Constit_Elmt
:= First_Elmt
(Constits
);
30162 while Present
(Constit_Elmt
) loop
30163 Constit_Id
:= Node
(Constit_Elmt
);
30165 -- Generate an error message of the form:
30167 -- state ... has unused Part_Of constituents
30168 -- abstract state ... defined at ...
30169 -- constant ... defined at ...
30170 -- variable ... defined at ...
30175 ("state & has unused Part_Of constituents",
30179 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
30181 if Ekind
(Constit_Id
) = E_Abstract_State
then
30183 ("\abstract state & defined #", State
, Constit_Id
);
30185 elsif Ekind
(Constit_Id
) = E_Constant
then
30187 ("\constant & defined #", State
, Constit_Id
);
30190 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
30191 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
30194 Next_Elmt
(Constit_Elmt
);
30197 end Report_Unused_Constituents
;
30199 -- Local declarations
30201 Body_Ref
: Node_Id
;
30202 Body_Ref_Elmt
: Elmt_Id
;
30204 Extra_State
: Node_Id
;
30206 -- Start of processing for Analyze_Refinement_Clause
30209 -- A refinement clause appears as a component association where the
30210 -- sole choice is the state and the expressions are the constituents.
30211 -- This is a syntax error, always report.
30213 if Nkind
(Clause
) /= N_Component_Association
then
30214 Error_Msg_N
("malformed state refinement clause", Clause
);
30218 -- Analyze the state name of a refinement clause
30220 State
:= First
(Choices
(Clause
));
30223 Resolve_State
(State
);
30225 -- Ensure that the state name denotes a valid abstract state that is
30226 -- defined in the spec of the related package.
30228 if Is_Entity_Name
(State
) then
30229 State_Id
:= Entity_Of
(State
);
30231 -- When the abstract state is undefined, it appears as Any_Id. Do
30232 -- not continue with the analysis of the clause.
30234 if State_Id
= Any_Id
then
30237 -- Catch any attempts to re-refine a state or refine a state that
30238 -- is not defined in the package declaration.
30240 elsif Ekind
(State_Id
) = E_Abstract_State
then
30244 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
30248 -- References to a state with visible refinement are illegal.
30249 -- When nested packages are involved, detecting such references is
30250 -- tricky because pragma Refined_State is analyzed later than the
30251 -- offending pragma Depends or Global. References that occur in
30252 -- such nested context are stored in a list. Emit errors for all
30253 -- references found in Body_References (SPARK RM 6.1.4(8)).
30255 if Present
(Body_References
(State_Id
)) then
30256 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
30257 while Present
(Body_Ref_Elmt
) loop
30258 Body_Ref
:= Node
(Body_Ref_Elmt
);
30260 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
30261 Error_Msg_Sloc
:= Sloc
(State
);
30262 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
30264 Next_Elmt
(Body_Ref_Elmt
);
30268 -- The state name is illegal. This is a syntax error, always report.
30271 Error_Msg_N
("malformed state name in refinement clause", State
);
30275 -- A refinement clause may only refine one state at a time
30277 Extra_State
:= Next
(State
);
30279 if Present
(Extra_State
) then
30281 ("refinement clause cannot cover multiple states", Extra_State
);
30284 -- Replicate the Part_Of constituents of the refined state because
30285 -- the algorithm will consume items.
30287 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
30289 -- Analyze all constituents of the refinement. Multiple constituents
30290 -- appear as an aggregate.
30292 Constit
:= Expression
(Clause
);
30294 if Nkind
(Constit
) = N_Aggregate
then
30295 if Present
(Component_Associations
(Constit
)) then
30297 ("constituents of refinement clause must appear in "
30298 & "positional form", Constit
);
30300 else pragma Assert
(Present
(Expressions
(Constit
)));
30301 Constit
:= First
(Expressions
(Constit
));
30302 while Present
(Constit
) loop
30303 Analyze_Constituent
(Constit
);
30308 -- Various forms of a single constituent. Note that these may include
30309 -- malformed constituents.
30312 Analyze_Constituent
(Constit
);
30315 -- Verify that external constituents do not introduce new external
30316 -- property in the state refinement (SPARK RM 7.2.8(2)).
30318 if Is_External_State
(State_Id
) then
30319 Check_External_Property
30320 (Prop_Nam
=> Name_Async_Readers
,
30321 Enabled
=> Async_Readers_Enabled
(State_Id
),
30322 Constit
=> AR_Constit
);
30324 Check_External_Property
30325 (Prop_Nam
=> Name_Async_Writers
,
30326 Enabled
=> Async_Writers_Enabled
(State_Id
),
30327 Constit
=> AW_Constit
);
30329 Check_External_Property
30330 (Prop_Nam
=> Name_Effective_Reads
,
30331 Enabled
=> Effective_Reads_Enabled
(State_Id
),
30332 Constit
=> ER_Constit
);
30334 Check_External_Property
30335 (Prop_Nam
=> Name_Effective_Writes
,
30336 Enabled
=> Effective_Writes_Enabled
(State_Id
),
30337 Constit
=> EW_Constit
);
30339 -- When a refined state is not external, it should not have external
30340 -- constituents (SPARK RM 7.2.8(1)).
30342 elsif External_Constit_Seen
then
30344 ("non-external state & cannot contain external constituents in "
30345 & "refinement", State
, State_Id
);
30348 -- Ensure that all Part_Of candidate constituents have been mentioned
30349 -- in the refinement clause.
30351 Report_Unused_Constituents
(Part_Of_Constits
);
30353 -- Avoid a cascading error reporting a missing refinement by adding a
30354 -- dummy constituent.
30356 if No
(Refinement_Constituents
(State_Id
)) then
30357 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
(Any_Id
));
30360 -- At this point the refinement might be dummy, but must be
30361 -- well-formed, to prevent cascaded errors.
30363 pragma Assert
(Has_Null_Refinement
(State_Id
)
30365 Has_Non_Null_Refinement
(State_Id
));
30366 end Analyze_Refinement_Clause
;
30368 -----------------------------
30369 -- Report_Unrefined_States --
30370 -----------------------------
30372 procedure Report_Unrefined_States
(States
: Elist_Id
) is
30373 State_Elmt
: Elmt_Id
;
30376 if Present
(States
) then
30377 State_Elmt
:= First_Elmt
(States
);
30378 while Present
(State_Elmt
) loop
30380 ("abstract state & must be refined", Node
(State_Elmt
));
30382 Next_Elmt
(State_Elmt
);
30385 end Report_Unrefined_States
;
30387 -- Local declarations
30389 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
30392 -- Start of processing for Analyze_Refined_State_In_Decl_Part
30395 -- Do not analyze the pragma multiple times
30397 if Is_Analyzed_Pragma
(N
) then
30401 -- Save the scenario for examination by the ABE Processing phase
30403 Record_Elaboration_Scenario
(N
);
30405 -- Replicate the abstract states declared by the package because the
30406 -- matching algorithm will consume states.
30408 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
30410 -- Gather all abstract states and objects declared in the visible
30411 -- state space of the package body. These items must be utilized as
30412 -- constituents in a state refinement.
30414 Body_States
:= Collect_Body_States
(Body_Id
);
30416 -- Multiple non-null state refinements appear as an aggregate
30418 if Nkind
(Clauses
) = N_Aggregate
then
30419 if Present
(Expressions
(Clauses
)) then
30421 ("state refinements must appear as component associations",
30424 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
30425 Clause
:= First
(Component_Associations
(Clauses
));
30426 while Present
(Clause
) loop
30427 Analyze_Refinement_Clause
(Clause
);
30432 -- Various forms of a single state refinement. Note that these may
30433 -- include malformed refinements.
30436 Analyze_Refinement_Clause
(Clauses
);
30439 -- List all abstract states that were left unrefined
30441 Report_Unrefined_States
(Available_States
);
30443 Set_Is_Analyzed_Pragma
(N
);
30444 end Analyze_Refined_State_In_Decl_Part
;
30446 ---------------------------------------------
30447 -- Analyze_Subprogram_Variant_In_Decl_Part --
30448 ---------------------------------------------
30450 -- WARNING: This routine manages Ghost regions. Return statements must be
30451 -- replaced by gotos which jump to the end of the routine and restore the
30454 procedure Analyze_Subprogram_Variant_In_Decl_Part
30456 Freeze_Id
: Entity_Id
:= Empty
)
30458 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
30459 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30461 procedure Analyze_Variant
(Variant
: Node_Id
);
30462 -- Verify the legality of a single contract case
30464 ---------------------
30465 -- Analyze_Variant --
30466 ---------------------
30468 procedure Analyze_Variant
(Variant
: Node_Id
) is
30469 Direction
: Node_Id
;
30472 Extra_Direction
: Node_Id
;
30475 if Nkind
(Variant
) /= N_Component_Association
then
30476 Error_Msg_N
("wrong syntax in subprogram variant", Variant
);
30480 Direction
:= First
(Choices
(Variant
));
30481 Expr
:= Expression
(Variant
);
30483 -- Each variant must have exactly one direction
30485 Extra_Direction
:= Next
(Direction
);
30487 if Present
(Extra_Direction
) then
30489 ("subprogram variant case must have exactly one direction",
30493 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
30495 if Nkind
(Direction
) = N_Identifier
then
30496 if Chars
(Direction
) not in Name_Decreases
30500 Error_Msg_N
("wrong direction", Direction
);
30503 Error_Msg_N
("wrong syntax", Direction
);
30506 Errors
:= Serious_Errors_Detected
;
30508 -- Preanalyze_Assert_Expression, but without enforcing any of the two
30509 -- acceptable types.
30511 Preanalyze_Assert_Expression
(Expr
);
30513 -- Expression of a discrete type is allowed. Nothing more to check
30514 -- for structural variants.
30516 if Is_Discrete_Type
(Etype
(Expr
))
30517 or else Chars
(Direction
) = Name_Structural
30521 -- Expression of a Big_Integer type (or its ghost variant) is only
30522 -- allowed in Decreases clause.
30525 Is_RTE
(Base_Type
(Etype
(Expr
)), RE_Big_Integer
)
30527 Is_RTE
(Base_Type
(Etype
(Expr
)), RO_GH_Big_Integer
)
30529 if Chars
(Direction
) = Name_Increases
then
30531 ("Subprogram_Variant with Big_Integer can only decrease",
30535 -- Expression of other types is not allowed
30538 Error_Msg_N
("expected a discrete or Big_Integer type", Expr
);
30541 -- Emit a clarification message when the variant expression
30542 -- contains at least one undefined reference, possibly due
30543 -- to contract freezing.
30545 if Errors
/= Serious_Errors_Detected
30546 and then Present
(Freeze_Id
)
30547 and then Has_Undefined_Reference
(Expr
)
30549 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
30551 end Analyze_Variant
;
30555 Variants
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
30557 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
30558 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
30559 -- Save the Ghost-related attributes to restore on exit
30562 Restore_Scope
: Boolean := False;
30564 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
30567 -- Do not analyze the pragma multiple times
30569 if Is_Analyzed_Pragma
(N
) then
30573 -- Set the Ghost mode in effect from the pragma. Due to the delayed
30574 -- analysis of the pragma, the Ghost mode at point of declaration and
30575 -- point of analysis may not necessarily be the same. Use the mode in
30576 -- effect at the point of declaration.
30578 Set_Ghost_Mode
(N
);
30580 -- Single and multiple contract cases must appear in aggregate form. If
30581 -- this is not the case, then either the parser of the analysis of the
30582 -- pragma failed to produce an aggregate, e.g. when the contract is
30583 -- "null" or a "(null record)".
30586 (if Nkind
(Variants
) = N_Aggregate
30587 then Null_Record_Present
(Variants
)
30588 xor (Present
(Component_Associations
(Variants
))
30590 Present
(Expressions
(Variants
)))
30591 else Nkind
(Variants
) = N_Null
);
30593 -- Only "change_direction => discrete_expression" clauses are allowed
30595 if Nkind
(Variants
) = N_Aggregate
30596 and then Present
(Component_Associations
(Variants
))
30597 and then No
(Expressions
(Variants
))
30600 -- Check that the expression is a proper aggregate (no parentheses)
30602 if Paren_Count
(Variants
) /= 0 then
30603 Error_Msg_F
-- CODEFIX
30604 ("redundant parentheses", Variants
);
30607 -- Ensure that the formal parameters are visible when analyzing all
30608 -- clauses. This falls out of the general rule of aspects pertaining
30609 -- to subprogram declarations.
30611 if not In_Open_Scopes
(Spec_Id
) then
30612 Restore_Scope
:= True;
30613 Push_Scope
(Spec_Id
);
30615 if Is_Generic_Subprogram
(Spec_Id
) then
30616 Install_Generic_Formals
(Spec_Id
);
30618 Install_Formals
(Spec_Id
);
30622 Variant
:= First
(Component_Associations
(Variants
));
30623 while Present
(Variant
) loop
30624 Analyze_Variant
(Variant
);
30626 if Chars
(First
(Choices
(Variant
))) = Name_Structural
30627 and then List_Length
(Component_Associations
(Variants
)) > 1
30630 ("Structural variant shall be the only variant", Variant
);
30636 if Restore_Scope
then
30640 -- Currently it is not possible to inline Subprogram_Variant on a
30641 -- subprogram subject to pragma Inline_Always.
30643 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
30645 -- Otherwise the pragma is illegal
30648 Error_Msg_N
("wrong syntax for subprogram variant", N
);
30651 Set_Is_Analyzed_Pragma
(N
);
30653 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
30654 end Analyze_Subprogram_Variant_In_Decl_Part
;
30656 ------------------------------------
30657 -- Analyze_Test_Case_In_Decl_Part --
30658 ------------------------------------
30660 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
30661 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
30662 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30664 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
30665 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
30666 -- denoted by Arg_Nam.
30668 ------------------------------
30669 -- Preanalyze_Test_Case_Arg --
30670 ------------------------------
30672 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
30676 -- Preanalyze the original aspect argument for a generic subprogram
30677 -- to properly capture global references.
30679 if Is_Generic_Subprogram
(Spec_Id
) then
30683 Arg_Nam
=> Arg_Nam
,
30684 From_Aspect
=> True);
30686 if Present
(Arg
) then
30687 Preanalyze_Assert_Expression
30688 (Expression
(Arg
), Standard_Boolean
);
30692 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
30694 if Present
(Arg
) then
30695 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
30697 end Preanalyze_Test_Case_Arg
;
30701 Restore_Scope
: Boolean := False;
30703 -- Start of processing for Analyze_Test_Case_In_Decl_Part
30706 -- Do not analyze the pragma multiple times
30708 if Is_Analyzed_Pragma
(N
) then
30712 -- Ensure that the formal parameters are visible when analyzing all
30713 -- clauses. This falls out of the general rule of aspects pertaining
30714 -- to subprogram declarations.
30716 if not In_Open_Scopes
(Spec_Id
) then
30717 Restore_Scope
:= True;
30718 Push_Scope
(Spec_Id
);
30720 if Is_Generic_Subprogram
(Spec_Id
) then
30721 Install_Generic_Formals
(Spec_Id
);
30723 Install_Formals
(Spec_Id
);
30727 Preanalyze_Test_Case_Arg
(Name_Requires
);
30728 Preanalyze_Test_Case_Arg
(Name_Ensures
);
30730 if Restore_Scope
then
30734 -- Currently it is not possible to inline pre/postconditions on a
30735 -- subprogram subject to pragma Inline_Always.
30737 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
30739 Set_Is_Analyzed_Pragma
(N
);
30740 end Analyze_Test_Case_In_Decl_Part
;
30746 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
30751 if Present
(List
) then
30752 Elmt
:= First_Elmt
(List
);
30753 while Present
(Elmt
) loop
30754 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
30757 Id
:= Entity_Of
(Node
(Elmt
));
30760 if Id
= Item_Id
then
30771 -----------------------------------
30772 -- Build_Pragma_Check_Equivalent --
30773 -----------------------------------
30775 function Build_Pragma_Check_Equivalent
30777 Subp_Id
: Entity_Id
:= Empty
;
30778 Inher_Id
: Entity_Id
:= Empty
;
30779 Keep_Pragma_Id
: Boolean := False) return Node_Id
30781 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
30782 -- Detect whether node N references a formal parameter subject to
30783 -- pragma Unreferenced. If this is the case, set Comes_From_Source
30784 -- to False to suppress the generation of a reference when analyzing
30787 ------------------------
30788 -- Suppress_Reference --
30789 ------------------------
30791 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
30792 Formal
: Entity_Id
;
30795 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30796 Formal
:= Entity
(N
);
30798 -- The formal parameter is subject to pragma Unreferenced. Prevent
30799 -- the generation of references by resetting the Comes_From_Source
30802 if Is_Formal
(Formal
)
30803 and then Has_Pragma_Unreferenced
(Formal
)
30805 Set_Comes_From_Source
(N
, False);
30810 end Suppress_Reference
;
30812 procedure Suppress_References
is
30813 new Traverse_Proc
(Suppress_Reference
);
30817 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
30818 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
30819 Check_Prag
: Node_Id
;
30823 -- Start of processing for Build_Pragma_Check_Equivalent
30826 -- When the pre- or postcondition is inherited, map the formals of the
30827 -- inherited subprogram to those of the current subprogram. In addition,
30828 -- map primitive operations of the parent type into the corresponding
30829 -- primitive operations of the descendant.
30831 if Present
(Inher_Id
) then
30832 pragma Assert
(Present
(Subp_Id
));
30834 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
30836 -- Use generic machinery to copy inherited pragma, as if it were an
30837 -- instantiation, resetting source locations appropriately, so that
30838 -- expressions inside the inherited pragma use chained locations.
30839 -- This is used in particular in GNATprove to locate precisely
30840 -- messages on a given inherited pragma.
30842 Set_Copied_Sloc_For_Inherited_Pragma
30843 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
30844 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
30846 -- Build the inherited class-wide condition
30848 Build_Class_Wide_Expression
30849 (Pragma_Or_Expr
=> Check_Prag
,
30851 Par_Subp
=> Inher_Id
,
30852 Adjust_Sloc
=> True);
30854 -- If not an inherited condition simply copy the original pragma
30857 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
30860 -- Mark the pragma as being internally generated and reset the Analyzed
30863 Set_Analyzed
(Check_Prag
, False);
30864 Set_Comes_From_Source
(Check_Prag
, False);
30866 -- The tree of the original pragma may contain references to the
30867 -- formal parameters of the related subprogram. At the same time
30868 -- the corresponding body may mark the formals as unreferenced:
30870 -- procedure Proc (Formal : ...)
30871 -- with Pre => Formal ...;
30873 -- procedure Proc (Formal : ...) is
30874 -- pragma Unreferenced (Formal);
30877 -- This creates problems because all pragma Check equivalents are
30878 -- analyzed at the end of the body declarations. Since all source
30879 -- references have already been accounted for, reset any references
30880 -- to such formals in the generated pragma Check equivalent.
30882 Suppress_References
(Check_Prag
);
30884 if Present
(Corresponding_Aspect
(Prag
)) then
30885 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
30890 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
30891 -- the copied pragma in the newly created pragma, convert the copy into
30892 -- pragma Check by correcting the name and adding a check_kind argument.
30894 if not Keep_Pragma_Id
then
30895 Set_Class_Present
(Check_Prag
, False);
30897 Set_Pragma_Identifier
30898 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
30900 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
30901 Make_Pragma_Argument_Association
(Loc
,
30902 Expression
=> Make_Identifier
(Loc
, Nam
)));
30905 -- Update the error message when the pragma is inherited
30907 if Present
(Inher_Id
) then
30908 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
30910 if Chars
(Msg_Arg
) = Name_Message
then
30911 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
30913 -- Insert "inherited" to improve the error message
30915 if Name_Buffer
(1 .. 8) = "failed p" then
30916 Insert_Str_In_Name_Buffer
("inherited ", 8);
30917 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
30923 end Build_Pragma_Check_Equivalent
;
30925 -----------------------------
30926 -- Check_Applicable_Policy --
30927 -----------------------------
30929 procedure Check_Applicable_Policy
(N
: Node_Id
) is
30933 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
30936 -- No effect if not valid assertion kind name
30938 if not Is_Valid_Assertion_Kind
(Ename
) then
30942 -- Loop through entries in check policy list
30944 PP
:= Opt
.Check_Policy_List
;
30945 while Present
(PP
) loop
30947 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
30948 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
30952 or else Pnm
= Name_Assertion
30953 or else (Pnm
= Name_Statement_Assertions
30954 and then Ename
in Name_Assert
30955 | Name_Assert_And_Cut
30957 | Name_Loop_Invariant
30958 | Name_Loop_Variant
)
30960 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
30966 -- In CodePeer mode and GNATprove mode, we need to
30967 -- consider all assertions, unless they are disabled.
30968 -- Force Is_Checked on ignored assertions, in particular
30969 -- because transformations of the AST may depend on
30970 -- assertions being checked (e.g. the translation of
30971 -- attribute 'Loop_Entry).
30973 if CodePeer_Mode
or GNATprove_Mode
then
30974 Set_Is_Checked
(N
, True);
30975 Set_Is_Ignored
(N
, False);
30977 Set_Is_Checked
(N
, False);
30978 Set_Is_Ignored
(N
, True);
30984 Set_Is_Checked
(N
, True);
30985 Set_Is_Ignored
(N
, False);
30987 when Name_Disable
=>
30988 Set_Is_Ignored
(N
, True);
30989 Set_Is_Checked
(N
, False);
30990 Set_Is_Disabled
(N
, True);
30992 -- That should be exhaustive, the null here is a defence
30993 -- against a malformed tree from previous errors.
31002 PP
:= Next_Pragma
(PP
);
31006 -- If there are no specific entries that matched, then we let the
31007 -- setting of assertions govern. Note that this provides the needed
31008 -- compatibility with the RM for the cases of assertion, invariant,
31009 -- precondition, predicate, and postcondition. Note also that
31010 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
31012 if Assertions_Enabled
then
31013 Set_Is_Checked
(N
, True);
31014 Set_Is_Ignored
(N
, False);
31016 Set_Is_Checked
(N
, False);
31017 Set_Is_Ignored
(N
, True);
31019 end Check_Applicable_Policy
;
31021 -------------------------------
31022 -- Check_External_Properties --
31023 -------------------------------
31025 procedure Check_External_Properties
31032 type Properties
is array (Positive range 1 .. 4) of Boolean;
31033 type Combinations
is array (Positive range <>) of Properties
;
31034 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
31035 -- Effective_Reads properties and their combinations, respectively.
31037 Specified
: constant Properties
:= (AR
, AW
, EW
, ER
);
31038 -- External properties, as given by the Item pragma
31040 Allowed
: constant Combinations
:=
31041 (1 => (True, False, True, False),
31042 2 => (False, True, False, True),
31043 3 => (True, False, False, False),
31044 4 => (False, True, False, False),
31045 5 => (True, True, True, False),
31046 6 => (True, True, False, True),
31047 7 => (True, True, False, False),
31048 8 => (True, True, True, True));
31049 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
31052 -- Check if the specified properties match any of the allowed
31053 -- combination; if not, then emit an error.
31055 for J
in Allowed
'Range loop
31056 if Specified
= Allowed
(J
) then
31062 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
31064 end Check_External_Properties
;
31070 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
31074 -- Loop through entries in check policy list
31076 PP
:= Opt
.Check_Policy_List
;
31077 while Present
(PP
) loop
31079 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
31080 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
31084 or else (Pnm
= Name_Assertion
31085 and then Is_Valid_Assertion_Kind
(Nam
))
31086 or else (Pnm
= Name_Statement_Assertions
31087 and then Nam
in Name_Assert
31088 | Name_Assert_And_Cut
31090 | Name_Loop_Invariant
31091 | Name_Loop_Variant
)
31093 case Chars
(Get_Pragma_Arg
(Last
(PPA
))) is
31102 return Name_Ignore
;
31104 when Name_Disable
=>
31105 return Name_Disable
;
31108 raise Program_Error
;
31112 PP
:= Next_Pragma
(PP
);
31117 -- If there are no specific entries that matched, then we let the
31118 -- setting of assertions govern. Note that this provides the needed
31119 -- compatibility with the RM for the cases of assertion, invariant,
31120 -- precondition, predicate, and postcondition.
31122 if Assertions_Enabled
then
31125 return Name_Ignore
;
31129 ---------------------------
31130 -- Check_Missing_Part_Of --
31131 ---------------------------
31133 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
31134 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
31135 -- Determine whether a package denoted by Pack_Id declares at least one
31138 -----------------------
31139 -- Has_Visible_State --
31140 -----------------------
31142 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
31143 Item_Id
: Entity_Id
;
31146 -- Traverse the entity chain of the package trying to find at least
31147 -- one visible abstract state, variable or a package [instantiation]
31148 -- that declares a visible state.
31150 Item_Id
:= First_Entity
(Pack_Id
);
31151 while Present
(Item_Id
)
31152 and then not In_Private_Part
(Item_Id
)
31154 -- Do not consider internally generated items
31156 if not Comes_From_Source
(Item_Id
) then
31159 -- Do not consider generic formals or their corresponding actuals
31160 -- because they are not part of a visible state. Note that both
31161 -- entities are marked as hidden.
31163 elsif Is_Hidden
(Item_Id
) then
31166 -- A visible state has been found. Note that constants are not
31167 -- considered here because it is not possible to determine whether
31168 -- they depend on variable input. This check is left to the SPARK
31171 elsif Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
31174 -- Recursively peek into nested packages and instantiations
31176 elsif Ekind
(Item_Id
) = E_Package
31177 and then Has_Visible_State
(Item_Id
)
31182 Next_Entity
(Item_Id
);
31186 end Has_Visible_State
;
31190 Pack_Id
: Entity_Id
;
31191 Placement
: State_Space_Kind
;
31193 -- Start of processing for Check_Missing_Part_Of
31196 -- Do not consider abstract states, variables or package instantiations
31197 -- coming from an instance as those always inherit the Part_Of indicator
31198 -- of the instance itself.
31200 if In_Instance
then
31203 -- Do not consider internally generated entities as these can never
31204 -- have a Part_Of indicator.
31206 elsif not Comes_From_Source
(Item_Id
) then
31209 -- Perform these checks only when SPARK_Mode is enabled as they will
31210 -- interfere with standard Ada rules and produce false positives.
31212 elsif SPARK_Mode
/= On
then
31215 -- Do not consider constants, because the compiler cannot accurately
31216 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
31217 -- act as a hidden state of a package.
31219 elsif Ekind
(Item_Id
) = E_Constant
then
31223 -- Find where the abstract state, variable or package instantiation
31224 -- lives with respect to the state space.
31226 Find_Placement_In_State_Space
31227 (Item_Id
=> Item_Id
,
31228 Placement
=> Placement
,
31229 Pack_Id
=> Pack_Id
);
31231 -- Items that appear in a non-package construct (subprogram, block, etc)
31232 -- do not require a Part_Of indicator because they can never act as a
31235 if Placement
= Not_In_Package
then
31238 -- An item declared in the body state space of a package always act as a
31239 -- constituent and does not need explicit Part_Of indicator.
31241 elsif Placement
= Body_State_Space
then
31244 -- In general an item declared in the visible state space of a package
31245 -- does not require a Part_Of indicator. The only exception is when the
31246 -- related package is a nongeneric private child unit, in which case
31247 -- Part_Of must denote a state in the parent unit or in one of its
31250 elsif Placement
= Visible_State_Space
then
31251 if Is_Child_Unit
(Pack_Id
)
31252 and then not Is_Generic_Unit
(Pack_Id
)
31253 and then Is_Private_Descendant
(Pack_Id
)
31255 -- A package instantiation does not need a Part_Of indicator when
31256 -- the related generic template has no visible state.
31258 if Ekind
(Item_Id
) = E_Package
31259 and then Is_Generic_Instance
(Item_Id
)
31260 and then not Has_Visible_State
(Item_Id
)
31264 -- All other cases require Part_Of
31268 ("indicator Part_Of is required in this context "
31269 & "(SPARK RM 7.2.6(3))", Item_Id
);
31270 Error_Msg_Name_1
:= Chars
(Pack_Id
);
31272 ("\& is declared in the visible part of private child "
31273 & "unit %", Item_Id
);
31277 -- When the item appears in the private state space of a package, it
31278 -- must be a part of some state declared by the said package.
31280 else pragma Assert
(Placement
= Private_State_Space
);
31282 -- The related package does not declare a state, the item cannot act
31283 -- as a Part_Of constituent.
31285 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
31288 -- A package instantiation does not need a Part_Of indicator when the
31289 -- related generic template has no visible state.
31291 elsif Ekind
(Item_Id
) = E_Package
31292 and then Is_Generic_Instance
(Item_Id
)
31293 and then not Has_Visible_State
(Item_Id
)
31297 -- All other cases require Part_Of
31300 Error_Msg_Code
:= GEC_Required_Part_Of
;
31302 ("indicator Part_Of is required in this context '[[]']",
31304 Error_Msg_Name_1
:= Chars
(Pack_Id
);
31306 ("\& is declared in the private part of package %", Item_Id
);
31309 end Check_Missing_Part_Of
;
31311 ---------------------------------------------------
31312 -- Check_Postcondition_Use_In_Inlined_Subprogram --
31313 ---------------------------------------------------
31315 procedure Check_Postcondition_Use_In_Inlined_Subprogram
31317 Spec_Id
: Entity_Id
)
31320 if Warn_On_Redundant_Constructs
31321 and then Has_Pragma_Inline_Always
(Spec_Id
)
31322 and then Assertions_Enabled
31323 and then not Back_End_Inlining
31325 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
31327 if From_Aspect_Specification
(Prag
) then
31329 ("aspect % not enforced on inlined subprogram &?r?",
31330 Corresponding_Aspect
(Prag
), Spec_Id
);
31333 ("pragma % not enforced on inlined subprogram &?r?",
31337 end Check_Postcondition_Use_In_Inlined_Subprogram
;
31339 -------------------------------------
31340 -- Check_State_And_Constituent_Use --
31341 -------------------------------------
31343 procedure Check_State_And_Constituent_Use
31344 (States
: Elist_Id
;
31345 Constits
: Elist_Id
;
31348 Constit_Elmt
: Elmt_Id
;
31349 Constit_Id
: Entity_Id
;
31350 State_Id
: Entity_Id
;
31353 -- Nothing to do if there are no states or constituents
31355 if No
(States
) or else No
(Constits
) then
31359 -- Inspect the list of constituents and try to determine whether its
31360 -- encapsulating state is in list States.
31362 Constit_Elmt
:= First_Elmt
(Constits
);
31363 while Present
(Constit_Elmt
) loop
31364 Constit_Id
:= Node
(Constit_Elmt
);
31366 -- Determine whether the constituent is part of an encapsulating
31367 -- state that appears in the same context and if this is the case,
31368 -- emit an error (SPARK RM 7.2.6(7)).
31370 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
31372 if Present
(State_Id
) then
31373 Error_Msg_Name_1
:= Chars
(Constit_Id
);
31375 ("cannot mention state & and its constituent % in the same "
31376 & "context", Context
, State_Id
);
31380 Next_Elmt
(Constit_Elmt
);
31382 end Check_State_And_Constituent_Use
;
31384 ---------------------------------------------
31385 -- Collect_Inherited_Class_Wide_Conditions --
31386 ---------------------------------------------
31388 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
31389 Parent_Subp
: constant Entity_Id
:=
31390 Ultimate_Alias
(Overridden_Operation
(Subp
));
31391 -- The Overridden_Operation may itself be inherited and as such have no
31392 -- explicit contract.
31394 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
31395 In_Spec_Expr
: Boolean := In_Spec_Expression
;
31396 Installed
: Boolean;
31398 New_Prag
: Node_Id
;
31401 Installed
:= False;
31403 -- Iterate over the contract of the overridden subprogram to find all
31404 -- inherited class-wide pre- and postconditions.
31406 if Present
(Prags
) then
31407 Prag
:= Pre_Post_Conditions
(Prags
);
31409 while Present
(Prag
) loop
31410 if Pragma_Name_Unmapped
(Prag
)
31411 in Name_Precondition | Name_Postcondition
31412 and then Class_Present
(Prag
)
31414 -- The generated pragma must be analyzed in the context of
31415 -- the subprogram, to make its formals visible. In addition,
31416 -- we must inhibit freezing and full analysis because the
31417 -- controlling type of the subprogram is not frozen yet, and
31418 -- may have further primitives.
31420 if not Installed
then
31423 Install_Formals
(Subp
);
31424 In_Spec_Expr
:= In_Spec_Expression
;
31425 In_Spec_Expression
:= True;
31429 Build_Pragma_Check_Equivalent
31430 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
31432 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
31433 Preanalyze
(New_Prag
);
31435 -- Prevent further analysis in subsequent processing of the
31436 -- current list of declarations
31438 Set_Analyzed
(New_Prag
);
31441 Prag
:= Next_Pragma
(Prag
);
31445 In_Spec_Expression
:= In_Spec_Expr
;
31449 end Collect_Inherited_Class_Wide_Conditions
;
31451 ---------------------------------------
31452 -- Collect_Subprogram_Inputs_Outputs --
31453 ---------------------------------------
31455 procedure Collect_Subprogram_Inputs_Outputs
31456 (Subp_Id
: Entity_Id
;
31457 Synthesize
: Boolean := False;
31458 Subp_Inputs
: in out Elist_Id
;
31459 Subp_Outputs
: in out Elist_Id
;
31460 Global_Seen
: out Boolean)
31462 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
31463 -- Collect all relevant items from a dependency clause
31465 procedure Collect_Global_List
31467 Mode
: Name_Id
:= Name_Input
);
31468 -- Collect all relevant items from a global list
31470 -------------------------------
31471 -- Collect_Dependency_Clause --
31472 -------------------------------
31474 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
31475 procedure Collect_Dependency_Item
31477 Is_Input
: Boolean);
31478 -- Add an item to the proper subprogram input or output collection
31480 -----------------------------
31481 -- Collect_Dependency_Item --
31482 -----------------------------
31484 procedure Collect_Dependency_Item
31486 Is_Input
: Boolean)
31491 -- Nothing to collect when the item is null
31493 if Nkind
(Item
) = N_Null
then
31496 -- Ditto for attribute 'Result
31498 elsif Is_Attribute_Result
(Item
) then
31501 -- Multiple items appear as an aggregate
31503 elsif Nkind
(Item
) = N_Aggregate
then
31504 Extra
:= First
(Expressions
(Item
));
31505 while Present
(Extra
) loop
31506 Collect_Dependency_Item
(Extra
, Is_Input
);
31510 -- Otherwise this is a solitary item
31514 Append_New_Elmt
(Item
, Subp_Inputs
);
31516 Append_New_Elmt
(Item
, Subp_Outputs
);
31519 end Collect_Dependency_Item
;
31521 -- Start of processing for Collect_Dependency_Clause
31524 if Nkind
(Clause
) = N_Null
then
31527 -- A dependency clause appears as component association
31529 elsif Nkind
(Clause
) = N_Component_Association
then
31530 Collect_Dependency_Item
31531 (Item
=> Expression
(Clause
),
31534 Collect_Dependency_Item
31535 (Item
=> First
(Choices
(Clause
)),
31536 Is_Input
=> False);
31538 -- To accommodate partial decoration of disabled SPARK features, this
31539 -- routine may be called with illegal input. If this is the case, do
31540 -- not raise Program_Error.
31545 end Collect_Dependency_Clause
;
31547 -------------------------
31548 -- Collect_Global_List --
31549 -------------------------
31551 procedure Collect_Global_List
31553 Mode
: Name_Id
:= Name_Input
)
31555 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
31556 -- Add an item to the proper subprogram input or output collection
31558 -------------------------
31559 -- Collect_Global_Item --
31560 -------------------------
31562 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
31564 if Mode
in Name_In_Out | Name_Input
then
31565 Append_New_Elmt
(Item
, Subp_Inputs
);
31568 if Mode
in Name_In_Out | Name_Output
then
31569 Append_New_Elmt
(Item
, Subp_Outputs
);
31571 end Collect_Global_Item
;
31578 -- Start of processing for Collect_Global_List
31581 if Nkind
(List
) = N_Null
then
31584 -- Single global item declaration
31586 elsif Nkind
(List
) in N_Expanded_Name
31588 | N_Selected_Component
31590 Collect_Global_Item
(List
, Mode
);
31592 -- Simple global list or moded global list declaration
31594 elsif Nkind
(List
) = N_Aggregate
then
31595 if Present
(Expressions
(List
)) then
31596 Item
:= First
(Expressions
(List
));
31597 while Present
(Item
) loop
31598 Collect_Global_Item
(Item
, Mode
);
31603 Assoc
:= First
(Component_Associations
(List
));
31604 while Present
(Assoc
) loop
31605 Collect_Global_List
31606 (List
=> Expression
(Assoc
),
31607 Mode
=> Chars
(First
(Choices
(Assoc
))));
31612 -- To accommodate partial decoration of disabled SPARK features, this
31613 -- routine may be called with illegal input. If this is the case, do
31614 -- not raise Program_Error.
31619 end Collect_Global_List
;
31626 Formal
: Entity_Id
;
31628 Spec_Id
: Entity_Id
:= Empty
;
31629 Subp_Decl
: Node_Id
;
31632 -- Start of processing for Collect_Subprogram_Inputs_Outputs
31635 Global_Seen
:= False;
31637 -- Process all formal parameters of entries, [generic] subprograms, and
31640 if Ekind
(Subp_Id
) in E_Entry
31643 | E_Generic_Function
31644 | E_Generic_Procedure
31646 | E_Subprogram_Body
31648 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
31649 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
31651 -- Process all formal parameters
31653 Formal
:= First_Formal
(Spec_Id
);
31654 while Present
(Formal
) loop
31655 if Ekind
(Formal
) in E_In_Out_Parameter | E_In_Parameter
then
31656 Append_New_Elmt
(Formal
, Subp_Inputs
);
31659 if Ekind
(Formal
) in E_In_Out_Parameter | E_Out_Parameter
then
31660 Append_New_Elmt
(Formal
, Subp_Outputs
);
31662 -- OUT parameters can act as inputs when the related type is
31663 -- tagged, unconstrained array, unconstrained record, or record
31664 -- with unconstrained components.
31666 if Ekind
(Formal
) = E_Out_Parameter
31667 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
31669 Append_New_Elmt
(Formal
, Subp_Inputs
);
31673 -- IN parameters of procedures and protected entries can act as
31674 -- outputs when the related type is access-to-variable.
31676 if Ekind
(Formal
) = E_In_Parameter
31677 and then Ekind
(Spec_Id
) not in E_Function
31678 | E_Generic_Function
31679 and then Is_Access_Variable
(Etype
(Formal
))
31681 Append_New_Elmt
(Formal
, Subp_Outputs
);
31684 Next_Formal
(Formal
);
31687 -- Otherwise the input denotes a task type, a task body, or the
31688 -- anonymous object created for a single task type.
31690 elsif Ekind
(Subp_Id
) in E_Task_Type | E_Task_Body
31691 or else Is_Single_Task_Object
(Subp_Id
)
31693 Subp_Decl
:= Declaration_Node
(Subp_Id
);
31694 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
31697 -- When processing an entry, subprogram or task body, look for pragmas
31698 -- Refined_Depends and Refined_Global as they specify the inputs and
31701 if Is_Entry_Body
(Subp_Id
)
31702 or else Ekind
(Subp_Id
) in E_Subprogram_Body | E_Task_Body
31704 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
31705 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
31707 -- Subprogram declaration or stand-alone body case, look for pragmas
31708 -- Depends and Global.
31711 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
31712 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
31715 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
31716 -- because it provides finer granularity of inputs and outputs.
31718 if Present
(Global
) then
31719 Global_Seen
:= True;
31720 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
31722 -- When the related subprogram lacks pragma [Refined_]Global, fall back
31723 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
31724 -- the inputs and outputs from [Refined_]Depends.
31726 elsif Synthesize
and then Present
(Depends
) then
31727 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
31729 -- Multiple dependency clauses appear as an aggregate
31731 if Nkind
(Clauses
) = N_Aggregate
then
31732 Clause
:= First
(Component_Associations
(Clauses
));
31733 while Present
(Clause
) loop
31734 Collect_Dependency_Clause
(Clause
);
31738 -- Otherwise this is a single dependency clause
31741 Collect_Dependency_Clause
(Clauses
);
31745 -- The current instance of a protected type acts as a formal parameter
31746 -- of mode IN for functions and IN OUT for entries and procedures
31747 -- (SPARK RM 6.1.4).
31749 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
31750 Typ
:= Scope
(Spec_Id
);
31752 -- Use the anonymous object when the type is single protected
31754 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
31755 Typ
:= Anonymous_Object
(Typ
);
31758 Append_New_Elmt
(Typ
, Subp_Inputs
);
31760 if Ekind
(Spec_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
31761 Append_New_Elmt
(Typ
, Subp_Outputs
);
31764 -- The current instance of a task type acts as a formal parameter of
31765 -- mode IN OUT (SPARK RM 6.1.4).
31767 elsif Ekind
(Spec_Id
) = E_Task_Type
then
31770 -- Use the anonymous object when the type is single task
31772 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
31773 Typ
:= Anonymous_Object
(Typ
);
31776 Append_New_Elmt
(Typ
, Subp_Inputs
);
31777 Append_New_Elmt
(Typ
, Subp_Outputs
);
31779 elsif Is_Single_Task_Object
(Spec_Id
) then
31780 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
31781 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
31783 end Collect_Subprogram_Inputs_Outputs
;
31785 ---------------------------
31786 -- Contract_Freeze_Error --
31787 ---------------------------
31789 procedure Contract_Freeze_Error
31790 (Contract_Id
: Entity_Id
;
31791 Freeze_Id
: Entity_Id
)
31794 Error_Msg_Name_1
:= Chars
(Contract_Id
);
31795 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
31798 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
31800 ("\all contractual items must be declared before body #", Contract_Id
);
31801 end Contract_Freeze_Error
;
31803 ---------------------------------
31804 -- Delay_Config_Pragma_Analyze --
31805 ---------------------------------
31807 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
31809 return Pragma_Name_Unmapped
(N
)
31810 in Name_Interrupt_State | Name_Priority_Specific_Dispatching
;
31811 end Delay_Config_Pragma_Analyze
;
31813 -----------------------
31814 -- Duplication_Error --
31815 -----------------------
31817 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
31818 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
31819 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
31822 Error_Msg_Sloc
:= Sloc
(Prev
);
31823 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
31825 -- Emit a precise message to distinguish between source pragmas and
31826 -- pragmas generated from aspects. The ordering of the two pragmas is
31830 -- Prag -- duplicate
31832 -- No error is emitted when both pragmas come from aspects because this
31833 -- is already detected by the general aspect analysis mechanism.
31835 if Prag_From_Asp
and Prev_From_Asp
then
31837 elsif Prag_From_Asp
then
31838 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
31839 elsif Prev_From_Asp
then
31840 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
31842 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
31844 end Duplication_Error
;
31846 ------------------------------
31847 -- Find_Encapsulating_State --
31848 ------------------------------
31850 function Find_Encapsulating_State
31851 (States
: Elist_Id
;
31852 Constit_Id
: Entity_Id
) return Entity_Id
31854 State_Id
: Entity_Id
;
31857 -- Since a constituent may be part of a larger constituent set, climb
31858 -- the encapsulating state chain looking for a state that appears in
31861 State_Id
:= Encapsulating_State
(Constit_Id
);
31862 while Present
(State_Id
) loop
31863 if Contains
(States
, State_Id
) then
31867 State_Id
:= Encapsulating_State
(State_Id
);
31871 end Find_Encapsulating_State
;
31873 --------------------------
31874 -- Find_Related_Context --
31875 --------------------------
31877 function Find_Related_Context
31879 Do_Checks
: Boolean := False) return Node_Id
31884 -- If the pragma comes from an aspect on a compilation unit that is a
31885 -- package instance, then return the original package instantiation
31888 if Nkind
(Parent
(Prag
)) = N_Compilation_Unit_Aux
then
31890 Get_Unit_Instantiation_Node
31891 (Defining_Entity
(Unit
(Enclosing_Comp_Unit_Node
(Prag
))));
31894 Stmt
:= Prev
(Prag
);
31895 while Present
(Stmt
) loop
31897 -- Skip prior pragmas, but check for duplicates
31899 if Nkind
(Stmt
) = N_Pragma
then
31901 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
31908 -- Skip internally generated code
31910 elsif not Comes_From_Source
(Stmt
)
31911 and then not Comes_From_Source
(Original_Node
(Stmt
))
31914 -- The anonymous object created for a single concurrent type is a
31915 -- suitable context.
31917 if Nkind
(Stmt
) = N_Object_Declaration
31918 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
31923 -- Return the current source construct
31933 end Find_Related_Context
;
31935 --------------------------------------
31936 -- Find_Related_Declaration_Or_Body --
31937 --------------------------------------
31939 function Find_Related_Declaration_Or_Body
31941 Do_Checks
: Boolean := False) return Node_Id
31943 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
31945 procedure Expression_Function_Error
;
31946 -- Emit an error concerning pragma Prag that illegaly applies to an
31947 -- expression function.
31949 -------------------------------
31950 -- Expression_Function_Error --
31951 -------------------------------
31953 procedure Expression_Function_Error
is
31955 Error_Msg_Name_1
:= Prag_Nam
;
31957 -- Emit a precise message to distinguish between source pragmas and
31958 -- pragmas generated from aspects.
31960 if From_Aspect_Specification
(Prag
) then
31962 ("aspect % cannot apply to a standalone expression function",
31966 ("pragma % cannot apply to a standalone expression function",
31969 end Expression_Function_Error
;
31973 Context
: constant Node_Id
:= Parent
(Prag
);
31976 Look_For_Body
: constant Boolean :=
31977 Prag_Nam
in Name_Refined_Depends
31978 | Name_Refined_Global
31979 | Name_Refined_Post
31980 | Name_Refined_State
;
31981 -- Refinement pragmas must be associated with a subprogram body [stub]
31983 -- Start of processing for Find_Related_Declaration_Or_Body
31986 Stmt
:= Prev
(Prag
);
31987 while Present
(Stmt
) loop
31989 -- Skip prior pragmas, but check for duplicates. Pragmas produced
31990 -- by splitting a complex pre/postcondition are not considered to
31993 if Nkind
(Stmt
) = N_Pragma
then
31995 and then not Split_PPC
(Stmt
)
31996 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
32003 -- Emit an error when a refinement pragma appears on an expression
32004 -- function without a completion.
32007 and then Look_For_Body
32008 and then Nkind
(Stmt
) = N_Subprogram_Declaration
32009 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
32010 and then not Has_Completion
(Defining_Entity
(Stmt
))
32012 Expression_Function_Error
;
32015 -- The refinement pragma applies to a subprogram body stub
32017 elsif Look_For_Body
32018 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
32022 -- Skip internally generated code
32024 elsif not Comes_From_Source
(Stmt
) then
32026 -- The anonymous object created for a single concurrent type is a
32027 -- suitable context.
32029 if Nkind
(Stmt
) = N_Object_Declaration
32030 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
32034 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
32036 -- The subprogram declaration is an internally generated spec
32037 -- for an expression function.
32039 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
32042 -- The subprogram declaration is an internally generated spec
32043 -- for a stand-alone subprogram body declared inside a
32046 elsif Present
(Corresponding_Body
(Stmt
))
32047 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
32048 and then Is_Protected_Type
(Current_Scope
)
32052 -- The subprogram is actually an instance housed within an
32053 -- anonymous wrapper package.
32055 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
32058 -- Ada 2022: contract on formal subprogram or on generated
32059 -- Access_Subprogram_Wrapper, which appears after the related
32060 -- Access_Subprogram declaration.
32062 elsif Is_Generic_Actual_Subprogram
(Defining_Entity
(Stmt
))
32063 and then Ada_Version
>= Ada_2022
32067 elsif Is_Access_Subprogram_Wrapper
(Defining_Entity
(Stmt
))
32068 and then Ada_Version
>= Ada_2022
32074 -- Return the current construct which is either a subprogram body,
32075 -- a subprogram declaration or is illegal.
32084 -- If we fall through, then the pragma was either the first declaration
32085 -- or it was preceded by other pragmas and no source constructs.
32087 -- The pragma is associated with a library-level subprogram
32089 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
32090 return Unit
(Parent
(Context
));
32092 -- The pragma appears inside the declarations of an entry body
32094 elsif Nkind
(Context
) = N_Entry_Body
then
32097 -- The pragma appears inside the statements of a subprogram body at
32098 -- some nested level.
32100 elsif Is_Statement
(Context
)
32101 and then Present
(Enclosing_HSS
(Context
))
32103 return Parent
(Enclosing_HSS
(Context
));
32105 -- The pragma appears directly in the statements of a subprogram body
32107 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
32108 return Parent
(Context
);
32110 -- The pragma appears inside the declarative part of a package body
32112 elsif Nkind
(Context
) = N_Package_Body
then
32115 -- The pragma appears inside the declarative part of a subprogram body
32117 elsif Nkind
(Context
) = N_Subprogram_Body
then
32120 -- The pragma appears inside the declarative part of a task body
32122 elsif Nkind
(Context
) = N_Task_Body
then
32125 -- The pragma appears inside the visible part of a package specification
32127 elsif Nkind
(Context
) = N_Package_Specification
then
32128 return Parent
(Context
);
32130 -- The pragma is a byproduct of aspect expansion, return the related
32131 -- context of the original aspect. This case has a lower priority as
32132 -- the above circuitry pinpoints precisely the related context.
32134 elsif Present
(Corresponding_Aspect
(Prag
)) then
32135 return Parent
(Corresponding_Aspect
(Prag
));
32137 -- No candidate subprogram [body] found
32142 end Find_Related_Declaration_Or_Body
;
32144 ----------------------------------
32145 -- Find_Related_Package_Or_Body --
32146 ----------------------------------
32148 function Find_Related_Package_Or_Body
32150 Do_Checks
: Boolean := False) return Node_Id
32152 Context
: constant Node_Id
:= Parent
(Prag
);
32153 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
32157 Stmt
:= Prev
(Prag
);
32158 while Present
(Stmt
) loop
32160 -- Skip prior pragmas, but check for duplicates
32162 if Nkind
(Stmt
) = N_Pragma
then
32163 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
32169 -- Skip internally generated code
32171 elsif not Comes_From_Source
(Stmt
) then
32172 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
32174 -- The subprogram declaration is an internally generated spec
32175 -- for an expression function.
32177 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
32180 -- The subprogram is actually an instance housed within an
32181 -- anonymous wrapper package.
32183 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
32188 -- Return the current source construct which is illegal
32197 -- If we fall through, then the pragma was either the first declaration
32198 -- or it was preceded by other pragmas and no source constructs.
32200 -- The pragma is associated with a package. The immediate context in
32201 -- this case is the specification of the package.
32203 if Nkind
(Context
) = N_Package_Specification
then
32204 return Parent
(Context
);
32206 -- The pragma appears in the declarations of a package body
32208 elsif Nkind
(Context
) = N_Package_Body
then
32211 -- The pragma appears in the statements of a package body
32213 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
32214 and then Nkind
(Parent
(Context
)) = N_Package_Body
32216 return Parent
(Context
);
32218 -- The pragma is a byproduct of aspect expansion, return the related
32219 -- context of the original aspect. This case has a lower priority as
32220 -- the above circuitry pinpoints precisely the related context.
32222 elsif Present
(Corresponding_Aspect
(Prag
)) then
32223 return Parent
(Corresponding_Aspect
(Prag
));
32225 -- No candidate package [body] found
32230 end Find_Related_Package_Or_Body
;
32236 function Get_Argument
32238 Context_Id
: Entity_Id
:= Empty
) return Node_Id
32240 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
32243 -- Use the expression of the original aspect when analyzing the template
32244 -- of a generic unit. In both cases the aspect's tree must be decorated
32245 -- to save the global references in the generic context.
32247 if From_Aspect_Specification
(Prag
)
32248 and then Present
(Context_Id
)
32250 Is_Generic_Declaration_Or_Body
(Unit_Declaration_Node
(Context_Id
))
32252 return Corresponding_Aspect
(Prag
);
32254 -- Otherwise use the expression of the pragma
32256 elsif Present
(Args
) then
32257 return First
(Args
);
32264 -------------------------
32265 -- Get_Base_Subprogram --
32266 -------------------------
32268 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
32270 -- Follow subprogram renaming chain
32272 if Is_Subprogram
(Def_Id
)
32273 and then Parent_Kind
(Declaration_Node
(Def_Id
)) =
32274 N_Subprogram_Renaming_Declaration
32275 and then Present
(Alias
(Def_Id
))
32277 return Alias
(Def_Id
);
32281 end Get_Base_Subprogram
;
32283 -------------------------
32284 -- Get_SPARK_Mode_Type --
32285 -------------------------
32287 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
32297 -- Any other argument is illegal. Assume that no SPARK mode applies
32298 -- to avoid potential cascaded errors.
32303 end Get_SPARK_Mode_Type
;
32305 ------------------------------------
32306 -- Get_SPARK_Mode_From_Annotation --
32307 ------------------------------------
32309 function Get_SPARK_Mode_From_Annotation
32310 (N
: Node_Id
) return SPARK_Mode_Type
32315 if Nkind
(N
) = N_Aspect_Specification
then
32316 Mode
:= Expression
(N
);
32318 else pragma Assert
(Nkind
(N
) = N_Pragma
);
32319 Mode
:= First
(Pragma_Argument_Associations
(N
));
32321 if Present
(Mode
) then
32322 Mode
:= Get_Pragma_Arg
(Mode
);
32326 -- Aspect or pragma SPARK_Mode specifies an explicit mode
32328 if Present
(Mode
) then
32329 if Nkind
(Mode
) = N_Identifier
then
32330 return Get_SPARK_Mode_Type
(Chars
(Mode
));
32332 -- In case of a malformed aspect or pragma, return the default None
32338 -- Otherwise the lack of an expression defaults SPARK_Mode to On
32343 end Get_SPARK_Mode_From_Annotation
;
32345 ---------------------------
32346 -- Has_Extra_Parentheses --
32347 ---------------------------
32349 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
32353 -- The aggregate should not have an expression list because a clause
32354 -- is always interpreted as a component association. The only way an
32355 -- expression list can sneak in is by adding extra parentheses around
32356 -- the individual clauses:
32358 -- Depends (Output => Input) -- proper form
32359 -- Depends ((Output => Input)) -- extra parentheses
32361 -- Since the extra parentheses are not allowed by the syntax of the
32362 -- pragma, flag them now to avoid emitting misleading errors down the
32365 if Nkind
(Clause
) = N_Aggregate
32366 and then Present
(Expressions
(Clause
))
32368 Expr
:= First
(Expressions
(Clause
));
32369 while Present
(Expr
) loop
32371 -- A dependency clause surrounded by extra parentheses appears
32372 -- as an aggregate of component associations with an optional
32373 -- Paren_Count set.
32375 if Nkind
(Expr
) = N_Aggregate
32376 and then Present
(Component_Associations
(Expr
))
32379 ("dependency clause contains extra parentheses", Expr
);
32381 -- Otherwise the expression is a malformed construct
32384 SPARK_Msg_N
("malformed dependency clause", Expr
);
32394 end Has_Extra_Parentheses
;
32400 procedure Initialize
is
32403 Compile_Time_Warnings_Errors
.Init
;
32412 Dummy
:= Dummy
+ 1;
32415 -----------------------------
32416 -- Is_Config_Static_String --
32417 -----------------------------
32419 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
32421 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
32422 -- This is an internal recursive function that is just like the outer
32423 -- function except that it adds the string to the name buffer rather
32424 -- than placing the string in the name buffer.
32426 ------------------------------
32427 -- Add_Config_Static_String --
32428 ------------------------------
32430 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
32437 if Nkind
(N
) = N_Op_Concat
then
32438 if Add_Config_Static_String
(Left_Opnd
(N
)) then
32439 N
:= Right_Opnd
(N
);
32445 if Nkind
(N
) /= N_String_Literal
then
32446 Error_Msg_N
("string literal expected for pragma argument", N
);
32450 for J
in 1 .. String_Length
(Strval
(N
)) loop
32451 C
:= Get_String_Char
(Strval
(N
), J
);
32453 if not In_Character_Range
(C
) then
32455 ("string literal contains invalid wide character",
32456 Sloc
(N
) + 1 + Source_Ptr
(J
));
32460 Add_Char_To_Name_Buffer
(Get_Character
(C
));
32465 end Add_Config_Static_String
;
32467 -- Start of processing for Is_Config_Static_String
32472 return Add_Config_Static_String
(Arg
);
32473 end Is_Config_Static_String
;
32475 -------------------------------
32476 -- Is_Elaboration_SPARK_Mode --
32477 -------------------------------
32479 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
32482 (Nkind
(N
) = N_Pragma
32483 and then Pragma_Name
(N
) = Name_SPARK_Mode
32484 and then Is_List_Member
(N
));
32486 -- Pragma SPARK_Mode affects the elaboration of a package body when it
32487 -- appears in the statement part of the body.
32490 Present
(Parent
(N
))
32491 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
32492 and then List_Containing
(N
) = Statements
(Parent
(N
))
32493 and then Present
(Parent
(Parent
(N
)))
32494 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
32495 end Is_Elaboration_SPARK_Mode
;
32497 -----------------------
32498 -- Is_Enabled_Pragma --
32499 -----------------------
32501 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
32505 if Present
(Prag
) then
32506 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32508 if Present
(Arg
) then
32509 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
32511 -- The lack of a Boolean argument automatically enables the pragma
32517 -- The pragma is missing, therefore it is not enabled
32522 end Is_Enabled_Pragma
;
32524 -----------------------------------------
32525 -- Is_Non_Significant_Pragma_Reference --
32526 -----------------------------------------
32528 -- This function makes use of the following static table which indicates
32529 -- whether appearance of some name in a given pragma is to be considered
32530 -- as a reference for the purposes of warnings about unreferenced objects.
32532 -- -1 indicates that appearance in any argument is significant
32533 -- 0 indicates that appearance in any argument is not significant
32534 -- +n indicates that appearance as argument n is significant, but all
32535 -- other arguments are not significant
32536 -- 9n arguments from n on are significant, before n insignificant
32538 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
32539 (Pragma_Abort_Defer
=> -1,
32540 Pragma_Abstract_State
=> -1,
32541 Pragma_Ada_83
=> -1,
32542 Pragma_Ada_95
=> -1,
32543 Pragma_Ada_05
=> -1,
32544 Pragma_Ada_2005
=> -1,
32545 Pragma_Ada_12
=> -1,
32546 Pragma_Ada_2012
=> -1,
32547 Pragma_Ada_2022
=> -1,
32548 Pragma_Aggregate_Individually_Assign
=> 0,
32549 Pragma_All_Calls_Remote
=> -1,
32550 Pragma_Allow_Integer_Address
=> -1,
32551 Pragma_Always_Terminates
=> -1,
32552 Pragma_Annotate
=> 93,
32553 Pragma_Assert
=> -1,
32554 Pragma_Assert_And_Cut
=> -1,
32555 Pragma_Assertion_Policy
=> 0,
32556 Pragma_Assume
=> -1,
32557 Pragma_Assume_No_Invalid_Values
=> 0,
32558 Pragma_Async_Readers
=> 0,
32559 Pragma_Async_Writers
=> 0,
32560 Pragma_Asynchronous
=> 0,
32561 Pragma_Atomic
=> 0,
32562 Pragma_Atomic_Components
=> 0,
32563 Pragma_Attach_Handler
=> -1,
32564 Pragma_Attribute_Definition
=> 92,
32565 Pragma_Check
=> -1,
32566 Pragma_Check_Float_Overflow
=> 0,
32567 Pragma_Check_Name
=> 0,
32568 Pragma_Check_Policy
=> 0,
32569 Pragma_CPP_Class
=> 0,
32570 Pragma_CPP_Constructor
=> 0,
32571 Pragma_CPP_Virtual
=> 0,
32572 Pragma_CPP_Vtable
=> 0,
32574 Pragma_C_Pass_By_Copy
=> 0,
32575 Pragma_Comment
=> -1,
32576 Pragma_Common_Object
=> 0,
32577 Pragma_CUDA_Device
=> -1,
32578 Pragma_CUDA_Execute
=> -1,
32579 Pragma_CUDA_Global
=> -1,
32580 Pragma_Compile_Time_Error
=> -1,
32581 Pragma_Compile_Time_Warning
=> -1,
32582 Pragma_Complete_Representation
=> 0,
32583 Pragma_Complex_Representation
=> 0,
32584 Pragma_Component_Alignment
=> 0,
32585 Pragma_Constant_After_Elaboration
=> 0,
32586 Pragma_Contract_Cases
=> -1,
32587 Pragma_Controlled
=> 0,
32588 Pragma_Convention
=> 0,
32589 Pragma_Convention_Identifier
=> 0,
32590 Pragma_Deadline_Floor
=> -1,
32591 Pragma_Debug
=> -1,
32592 Pragma_Debug_Policy
=> 0,
32593 Pragma_Default_Initial_Condition
=> -1,
32594 Pragma_Default_Scalar_Storage_Order
=> 0,
32595 Pragma_Default_Storage_Pool
=> 0,
32596 Pragma_Depends
=> -1,
32597 Pragma_Detect_Blocking
=> 0,
32598 Pragma_Disable_Atomic_Synchronization
=> 0,
32599 Pragma_Discard_Names
=> 0,
32600 Pragma_Dispatching_Domain
=> -1,
32601 Pragma_Effective_Reads
=> 0,
32602 Pragma_Effective_Writes
=> 0,
32603 Pragma_Elaborate
=> 0,
32604 Pragma_Elaborate_All
=> 0,
32605 Pragma_Elaborate_Body
=> 0,
32606 Pragma_Elaboration_Checks
=> 0,
32607 Pragma_Eliminate
=> 0,
32608 Pragma_Enable_Atomic_Synchronization
=> 0,
32609 Pragma_Exceptional_Cases
=> -1,
32610 Pragma_Export
=> -1,
32611 Pragma_Export_Function
=> -1,
32612 Pragma_Export_Object
=> -1,
32613 Pragma_Export_Procedure
=> -1,
32614 Pragma_Export_Valued_Procedure
=> -1,
32615 Pragma_Extend_System
=> -1,
32616 Pragma_Extensions_Allowed
=> 0,
32617 Pragma_Extensions_Visible
=> 0,
32618 Pragma_External
=> -1,
32619 Pragma_External_Name_Casing
=> 0,
32620 Pragma_Fast_Math
=> 0,
32621 Pragma_Favor_Top_Level
=> 0,
32622 Pragma_Finalize_Storage_Only
=> 0,
32624 Pragma_Global
=> -1,
32625 Pragma_GNAT_Annotate
=> 93,
32626 Pragma_Ident
=> -1,
32627 Pragma_Ignore_Pragma
=> 0,
32628 Pragma_Implementation_Defined
=> -1,
32629 Pragma_Implemented
=> -1,
32630 Pragma_Implicit_Packing
=> 0,
32631 Pragma_Import
=> 93,
32632 Pragma_Import_Function
=> 0,
32633 Pragma_Import_Object
=> 0,
32634 Pragma_Import_Procedure
=> 0,
32635 Pragma_Import_Valued_Procedure
=> 0,
32636 Pragma_Independent
=> 0,
32637 Pragma_Independent_Components
=> 0,
32638 Pragma_Initial_Condition
=> -1,
32639 Pragma_Initialize_Scalars
=> 0,
32640 Pragma_Initializes
=> -1,
32641 Pragma_Inline
=> 0,
32642 Pragma_Inline_Always
=> 0,
32643 Pragma_Inline_Generic
=> 0,
32644 Pragma_Inspection_Point
=> -1,
32645 Pragma_Interface
=> 92,
32646 Pragma_Interface_Name
=> 0,
32647 Pragma_Interrupt_Handler
=> -1,
32648 Pragma_Interrupt_Priority
=> -1,
32649 Pragma_Interrupt_State
=> -1,
32650 Pragma_Invariant
=> -1,
32651 Pragma_Keep_Names
=> 0,
32652 Pragma_License
=> 0,
32653 Pragma_Link_With
=> -1,
32654 Pragma_Linker_Alias
=> -1,
32655 Pragma_Linker_Constructor
=> -1,
32656 Pragma_Linker_Destructor
=> -1,
32657 Pragma_Linker_Options
=> -1,
32658 Pragma_Linker_Section
=> -1,
32660 Pragma_Lock_Free
=> 0,
32661 Pragma_Locking_Policy
=> 0,
32662 Pragma_Loop_Invariant
=> -1,
32663 Pragma_Loop_Optimize
=> 0,
32664 Pragma_Loop_Variant
=> -1,
32665 Pragma_Machine_Attribute
=> -1,
32667 Pragma_Main_Storage
=> -1,
32668 Pragma_Max_Entry_Queue_Depth
=> 0,
32669 Pragma_Max_Entry_Queue_Length
=> 0,
32670 Pragma_Max_Queue_Length
=> 0,
32671 Pragma_Memory_Size
=> 0,
32672 Pragma_No_Body
=> 0,
32673 Pragma_No_Caching
=> 0,
32674 Pragma_No_Component_Reordering
=> -1,
32675 Pragma_No_Elaboration_Code_All
=> 0,
32676 Pragma_No_Heap_Finalization
=> 0,
32677 Pragma_No_Inline
=> 0,
32678 Pragma_No_Return
=> 0,
32679 Pragma_No_Run_Time
=> -1,
32680 Pragma_No_Strict_Aliasing
=> -1,
32681 Pragma_No_Tagged_Streams
=> 0,
32682 Pragma_Normalize_Scalars
=> 0,
32683 Pragma_Obsolescent
=> 0,
32684 Pragma_Optimize
=> 0,
32685 Pragma_Optimize_Alignment
=> 0,
32686 Pragma_Ordered
=> 0,
32687 Pragma_Overflow_Mode
=> 0,
32688 Pragma_Overriding_Renamings
=> 0,
32691 Pragma_Part_Of
=> 0,
32692 Pragma_Partition_Elaboration_Policy
=> 0,
32693 Pragma_Passive
=> 0,
32694 Pragma_Persistent_BSS
=> 0,
32696 Pragma_Postcondition
=> -1,
32697 Pragma_Post_Class
=> -1,
32699 Pragma_Precondition
=> -1,
32700 Pragma_Predicate
=> -1,
32701 Pragma_Predicate_Failure
=> -1,
32702 Pragma_Preelaborable_Initialization
=> -1,
32703 Pragma_Preelaborate
=> 0,
32704 Pragma_Prefix_Exception_Messages
=> 0,
32705 Pragma_Pre_Class
=> -1,
32706 Pragma_Priority
=> -1,
32707 Pragma_Priority_Specific_Dispatching
=> 0,
32708 Pragma_Profile
=> 0,
32709 Pragma_Profile_Warnings
=> 0,
32710 Pragma_Propagate_Exceptions
=> 0,
32711 Pragma_Provide_Shift_Operators
=> 0,
32712 Pragma_Psect_Object
=> 0,
32714 Pragma_Pure_Function
=> 0,
32715 Pragma_Queuing_Policy
=> 0,
32716 Pragma_Rational
=> 0,
32717 Pragma_Ravenscar
=> 0,
32718 Pragma_Refined_Depends
=> -1,
32719 Pragma_Refined_Global
=> -1,
32720 Pragma_Refined_Post
=> -1,
32721 Pragma_Refined_State
=> 0,
32722 Pragma_Relative_Deadline
=> 0,
32723 Pragma_Remote_Access_Type
=> -1,
32724 Pragma_Remote_Call_Interface
=> -1,
32725 Pragma_Remote_Types
=> -1,
32726 Pragma_Rename_Pragma
=> 0,
32727 Pragma_Restricted_Run_Time
=> 0,
32728 Pragma_Restriction_Warnings
=> 0,
32729 Pragma_Restrictions
=> 0,
32730 Pragma_Reviewable
=> -1,
32731 Pragma_Side_Effects
=> 0,
32732 Pragma_Secondary_Stack_Size
=> -1,
32733 Pragma_Share_Generic
=> 0,
32734 Pragma_Shared
=> 0,
32735 Pragma_Shared_Passive
=> 0,
32736 Pragma_Short_Circuit_And_Or
=> 0,
32737 Pragma_Short_Descriptors
=> 0,
32738 Pragma_Simple_Storage_Pool_Type
=> 0,
32739 Pragma_Source_File_Name
=> 0,
32740 Pragma_Source_File_Name_Project
=> 0,
32741 Pragma_Source_Reference
=> 0,
32742 Pragma_SPARK_Mode
=> 0,
32743 Pragma_Static_Elaboration_Desired
=> 0,
32744 Pragma_Storage_Size
=> -1,
32745 Pragma_Storage_Unit
=> 0,
32746 Pragma_Stream_Convert
=> 0,
32747 Pragma_Style_Checks
=> 0,
32748 Pragma_Subprogram_Variant
=> -1,
32749 Pragma_Subtitle
=> 0,
32750 Pragma_Suppress
=> 0,
32751 Pragma_Suppress_All
=> 0,
32752 Pragma_Suppress_Debug_Info
=> 0,
32753 Pragma_Suppress_Exception_Locations
=> 0,
32754 Pragma_Suppress_Initialization
=> 0,
32755 Pragma_System_Name
=> 0,
32756 Pragma_Task_Dispatching_Policy
=> 0,
32757 Pragma_Task_Info
=> -1,
32758 Pragma_Task_Name
=> -1,
32759 Pragma_Task_Storage
=> -1,
32760 Pragma_Test_Case
=> -1,
32761 Pragma_Thread_Local_Storage
=> -1,
32762 Pragma_Time_Slice
=> -1,
32764 Pragma_Type_Invariant
=> -1,
32765 Pragma_Type_Invariant_Class
=> -1,
32766 Pragma_Unchecked_Union
=> 0,
32767 Pragma_Unevaluated_Use_Of_Old
=> 0,
32768 Pragma_Unimplemented_Unit
=> 0,
32769 Pragma_Universal_Aliasing
=> 0,
32770 Pragma_Unmodified
=> 0,
32771 Pragma_Unreferenced
=> 0,
32772 Pragma_Unreferenced_Objects
=> 0,
32773 Pragma_Unreserve_All_Interrupts
=> 0,
32774 Pragma_Unsuppress
=> 0,
32775 Pragma_Unused
=> 0,
32776 Pragma_Use_VADS_Size
=> 0,
32777 Pragma_User_Aspect_Definition
=> 0,
32778 Pragma_Validity_Checks
=> 0,
32779 Pragma_Volatile
=> 0,
32780 Pragma_Volatile_Components
=> 0,
32781 Pragma_Volatile_Full_Access
=> 0,
32782 Pragma_Volatile_Function
=> 0,
32783 Pragma_Warning_As_Error
=> 0,
32784 Pragma_Warnings
=> 0,
32785 Pragma_Weak_External
=> 0,
32786 Pragma_Wide_Character_Encoding
=> 0,
32787 Unknown_Pragma
=> 0);
32789 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
32795 function Arg_No
return Nat
;
32796 -- Returns an integer showing what argument we are in. A value of
32797 -- zero means we are not in any of the arguments.
32803 function Arg_No
return Nat
is
32808 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
32822 -- Start of processing for Non_Significant_Pragma_Reference
32825 -- Reference might appear either directly as expression of a pragma
32826 -- argument association, e.g. pragma Export (...), or within an
32827 -- aggregate with component associations, e.g. pragma Refined_State
32833 when N_Pragma_Argument_Association
=>
32835 when N_Aggregate | N_Component_Association
=>
32848 Id
:= Get_Pragma_Id
(Parent
(P
));
32849 C
:= Sig_Flags
(Id
);
32859 return AN
< (C
- 90);
32864 end Is_Non_Significant_Pragma_Reference
;
32866 ------------------------------
32867 -- Is_Pragma_String_Literal --
32868 ------------------------------
32870 -- This function returns true if the corresponding pragma argument is a
32871 -- static string expression. These are the only cases in which string
32872 -- literals can appear as pragma arguments. We also allow a string literal
32873 -- as the first argument to pragma Assert (although it will of course
32874 -- always generate a type error).
32876 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
32877 Pragn
: constant Node_Id
:= Parent
(Par
);
32878 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
32879 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
32885 N
:= First
(Assoc
);
32892 if Pname
= Name_Assert
then
32895 elsif Pname
= Name_Export
then
32898 elsif Pname
= Name_Ident
then
32901 elsif Pname
= Name_Import
then
32904 elsif Pname
= Name_Interface_Name
then
32907 elsif Pname
= Name_Linker_Alias
then
32910 elsif Pname
= Name_Linker_Section
then
32913 elsif Pname
= Name_Machine_Attribute
then
32916 elsif Pname
= Name_Source_File_Name
then
32919 elsif Pname
= Name_Source_Reference
then
32922 elsif Pname
= Name_Title
then
32925 elsif Pname
= Name_Subtitle
then
32931 end Is_Pragma_String_Literal
;
32933 ---------------------------
32934 -- Is_Private_SPARK_Mode --
32935 ---------------------------
32937 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
32940 (Nkind
(N
) = N_Pragma
32941 and then Pragma_Name
(N
) = Name_SPARK_Mode
32942 and then Is_List_Member
(N
));
32944 -- For pragma SPARK_Mode to be private, it has to appear in the private
32945 -- declarations of a package.
32948 Present
(Parent
(N
))
32949 and then Nkind
(Parent
(N
)) = N_Package_Specification
32950 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
32951 end Is_Private_SPARK_Mode
;
32953 -------------------------------------
32954 -- Is_Unconstrained_Or_Tagged_Item --
32955 -------------------------------------
32957 function Is_Unconstrained_Or_Tagged_Item
32958 (Item
: Entity_Id
) return Boolean
32960 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
32961 -- Determine whether record type Typ has at least one unconstrained
32964 ---------------------------------
32965 -- Has_Unconstrained_Component --
32966 ---------------------------------
32968 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
32972 Comp
:= First_Component
(Typ
);
32973 while Present
(Comp
) loop
32974 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
32978 Next_Component
(Comp
);
32982 end Has_Unconstrained_Component
;
32986 Typ
: constant Entity_Id
:= Etype
(Item
);
32988 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
32991 if Is_Tagged_Type
(Typ
) then
32994 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
32997 elsif Is_Record_Type
(Typ
) then
32998 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
33001 return Has_Unconstrained_Component
(Typ
);
33004 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
33010 end Is_Unconstrained_Or_Tagged_Item
;
33012 -----------------------------
33013 -- Is_Valid_Assertion_Kind --
33014 -----------------------------
33016 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
33023 | Name_Static_Predicate
33024 | Name_Dynamic_Predicate
33029 | Name_Type_Invariant
33030 | Name_uType_Invariant
33034 | Name_Assert_And_Cut
33036 | Name_Contract_Cases
33038 | Name_Default_Initial_Condition
33040 | Name_Ghost_Predicate
33041 | Name_Initial_Condition
33044 | Name_Loop_Invariant
33045 | Name_Loop_Variant
33046 | Name_Postcondition
33047 | Name_Precondition
33049 | Name_Refined_Post
33050 | Name_Statement_Assertions
33051 | Name_Subprogram_Variant
33058 end Is_Valid_Assertion_Kind
;
33060 --------------------------------------
33061 -- Process_Compilation_Unit_Pragmas --
33062 --------------------------------------
33064 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
33066 -- A special check for pragma Suppress_All, a very strange DEC pragma,
33067 -- strange because it comes at the end of the unit. Rational has the
33068 -- same name for a pragma, but treats it as a program unit pragma, In
33069 -- GNAT we just decide to allow it anywhere at all. If it appeared then
33070 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
33071 -- node, and we insert a pragma Suppress (All_Checks) at the start of
33072 -- the context clause to ensure the correct processing.
33074 if Has_Pragma_Suppress_All
(N
) then
33075 Prepend_To
(Context_Items
(N
),
33076 Make_Pragma
(Sloc
(N
),
33077 Chars
=> Name_Suppress
,
33078 Pragma_Argument_Associations
=> New_List
(
33079 Make_Pragma_Argument_Association
(Sloc
(N
),
33080 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
33083 -- Nothing else to do at the current time
33085 end Process_Compilation_Unit_Pragmas
;
33087 --------------------------------------------
33088 -- Validate_Compile_Time_Warning_Or_Error --
33089 --------------------------------------------
33091 procedure Validate_Compile_Time_Warning_Or_Error
33095 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33096 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
33097 Arg2
: constant Node_Id
:= Next
(Arg1
);
33099 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
33100 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
33103 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
33105 if Compile_Time_Known_Value
(Arg1x
) then
33106 if Is_True
(Expr_Value
(Arg1x
)) then
33108 -- We have already verified that the second argument is a static
33109 -- string expression. Its string value must be retrieved
33110 -- explicitly if it is a declared constant, otherwise it has
33111 -- been constant-folded previously.
33114 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
33115 Str
: constant String_Id
:=
33116 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
33117 Str_Len
: constant Nat
:= String_Length
(Str
);
33119 Force
: constant Boolean :=
33120 Prag_Id
= Pragma_Compile_Time_Warning
33121 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
33122 and then (Ekind
(Cent
) /= E_Package
33123 or else not In_Private_Part
(Cent
));
33124 -- Set True if this is the warning case, and we are in the
33125 -- visible part of a package spec, or in a subprogram spec,
33126 -- in which case we want to force the client to see the
33127 -- warning, even though it is not in the main unit.
33135 -- Loop through segments of message separated by line feeds.
33136 -- We output these segments as separate messages with
33137 -- continuation marks for all but the first.
33142 Error_Msg_Strlen
:= 0;
33144 -- Loop to copy characters from argument to error message
33148 exit when Ptr
> Str_Len
;
33149 CC
:= Get_String_Char
(Str
, Ptr
);
33152 -- Ignore wide chars ??? else store character
33154 if In_Character_Range
(CC
) then
33155 C
:= Get_Character
(CC
);
33156 exit when C
= ASCII
.LF
;
33157 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
33158 Error_Msg_String
(Error_Msg_Strlen
) := C
;
33162 -- Here with one line ready to go
33164 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
33166 -- If this is a warning in a spec, then we want clients
33167 -- to see the warning, so mark the message with the
33168 -- special sequence !! to force the warning. In the case
33169 -- of a package spec, we do not force this if we are in
33170 -- the private part of the spec.
33173 if Cont
= False then
33175 ("<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
33179 ("\<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
33182 -- Error, rather than warning, or in a body, so we do not
33183 -- need to force visibility for client (error will be
33184 -- output in any case, and this is the situation in which
33185 -- we do not want a client to get a warning, since the
33186 -- warning is in the body or the spec private part).
33189 if Cont
= False then
33191 ("<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
33195 ("\<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
33199 exit when Ptr
> Str_Len
;
33204 -- Arg1x is not known at compile time, so possibly issue an error
33205 -- or warning. This can happen only if the pragma's processing
33206 -- was deferred until after the back end is run (see
33207 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
33208 -- control switch applies to only the warning case.
33210 elsif Prag_Id
= Pragma_Compile_Time_Error
then
33211 Error_Msg_N
("condition is not known at compile time", Arg1x
);
33213 elsif Warn_On_Unknown_Compile_Time_Warning
then
33214 Error_Msg_N
("?_c?condition is not known at compile time", Arg1x
);
33216 end Validate_Compile_Time_Warning_Or_Error
;
33218 ------------------------------------
33219 -- Record_Possible_Body_Reference --
33220 ------------------------------------
33222 procedure Record_Possible_Body_Reference
33223 (State_Id
: Entity_Id
;
33227 Spec_Id
: Entity_Id
;
33230 -- Ensure that we are dealing with a reference to a state
33232 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
33234 -- Climb the tree starting from the reference looking for a package body
33235 -- whose spec declares the referenced state. This criteria automatically
33236 -- excludes references in package specs which are legal. Note that it is
33237 -- not wise to emit an error now as the package body may lack pragma
33238 -- Refined_State or the referenced state may not be mentioned in the
33239 -- refinement. This approach avoids the generation of misleading errors.
33242 while Present
(Context
) loop
33243 if Nkind
(Context
) = N_Package_Body
then
33244 Spec_Id
:= Corresponding_Spec
(Context
);
33246 if Contains
(Abstract_States
(Spec_Id
), State_Id
) then
33247 if No
(Body_References
(State_Id
)) then
33248 Set_Body_References
(State_Id
, New_Elmt_List
);
33251 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
33256 Context
:= Parent
(Context
);
33258 end Record_Possible_Body_Reference
;
33260 ------------------------------------------
33261 -- Relocate_Pragmas_To_Anonymous_Object --
33262 ------------------------------------------
33264 procedure Relocate_Pragmas_To_Anonymous_Object
33265 (Typ_Decl
: Node_Id
;
33266 Obj_Decl
: Node_Id
)
33270 Next_Decl
: Node_Id
;
33273 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
33274 Def
:= Protected_Definition
(Typ_Decl
);
33276 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
33277 Def
:= Task_Definition
(Typ_Decl
);
33280 -- The concurrent definition has a visible declaration list. Inspect it
33281 -- and relocate all canidate pragmas.
33283 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
33284 Decl
:= First
(Visible_Declarations
(Def
));
33285 while Present
(Decl
) loop
33287 -- Preserve the following declaration for iteration purposes due
33288 -- to possible relocation of a pragma.
33290 Next_Decl
:= Next
(Decl
);
33292 if Nkind
(Decl
) = N_Pragma
33293 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
33296 Insert_After
(Obj_Decl
, Decl
);
33298 -- Skip internally generated code
33300 elsif not Comes_From_Source
(Decl
) then
33303 -- No candidate pragmas are available for relocation
33312 end Relocate_Pragmas_To_Anonymous_Object
;
33314 ------------------------------
33315 -- Relocate_Pragmas_To_Body --
33316 ------------------------------
33318 procedure Relocate_Pragmas_To_Body
33319 (Subp_Body
: Node_Id
;
33320 Target_Body
: Node_Id
:= Empty
)
33322 procedure Relocate_Pragma
(Prag
: Node_Id
);
33323 -- Remove a single pragma from its current list and add it to the
33324 -- declarations of the proper body (either Subp_Body or Target_Body).
33326 ---------------------
33327 -- Relocate_Pragma --
33328 ---------------------
33330 procedure Relocate_Pragma
(Prag
: Node_Id
) is
33335 -- When subprogram stubs or expression functions are involves, the
33336 -- destination declaration list belongs to the proper body.
33338 if Present
(Target_Body
) then
33339 Target
:= Target_Body
;
33341 Target
:= Subp_Body
;
33344 Decls
:= Declarations
(Target
);
33348 Set_Declarations
(Target
, Decls
);
33351 -- Unhook the pragma from its current list
33354 Prepend
(Prag
, Decls
);
33355 end Relocate_Pragma
;
33359 Body_Id
: constant Entity_Id
:=
33360 Defining_Unit_Name
(Specification
(Subp_Body
));
33361 Next_Stmt
: Node_Id
;
33364 -- Start of processing for Relocate_Pragmas_To_Body
33367 -- Do not process a body that comes from a separate unit as no construct
33368 -- can possibly follow it.
33370 if not Is_List_Member
(Subp_Body
) then
33373 -- Do not relocate pragmas that follow a stub if the stub does not have
33376 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
33377 and then No
(Target_Body
)
33381 -- Do not process internally generated routine _Wrapped_Statements
33383 elsif Ekind
(Body_Id
) = E_Procedure
33384 and then Chars
(Body_Id
) = Name_uWrapped_Statements
33389 -- Look at what is following the body. We are interested in certain kind
33390 -- of pragmas (either from source or byproducts of expansion) that can
33391 -- apply to a body [stub].
33393 Stmt
:= Next
(Subp_Body
);
33394 while Present
(Stmt
) loop
33396 -- Preserve the following statement for iteration purposes due to a
33397 -- possible relocation of a pragma.
33399 Next_Stmt
:= Next
(Stmt
);
33401 -- Move a candidate pragma following the body to the declarations of
33404 if Nkind
(Stmt
) = N_Pragma
33405 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
33408 -- If a source pragma Warnings follows the body, it applies to
33409 -- following statements and does not belong in the body.
33411 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
33412 and then Comes_From_Source
(Stmt
)
33416 Relocate_Pragma
(Stmt
);
33419 -- Skip internally generated code
33421 elsif not Comes_From_Source
(Stmt
) then
33424 -- No candidate pragmas are available for relocation
33432 end Relocate_Pragmas_To_Body
;
33434 -------------------
33435 -- Resolve_State --
33436 -------------------
33438 procedure Resolve_State
(N
: Node_Id
) is
33443 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
33444 Func
:= Entity
(N
);
33446 -- Handle overloading of state names by functions. Traverse the
33447 -- homonym chain looking for an abstract state.
33449 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
33450 pragma Assert
(Is_Overloaded
(N
));
33452 State
:= Homonym
(Func
);
33453 while Present
(State
) loop
33454 if Ekind
(State
) = E_Abstract_State
then
33456 -- Resolve the overloading by setting the proper entity of
33457 -- the reference to that of the state.
33459 Set_Etype
(N
, Standard_Void_Type
);
33460 Set_Entity
(N
, State
);
33461 Set_Is_Overloaded
(N
, False);
33463 Generate_Reference
(State
, N
);
33467 State
:= Homonym
(State
);
33470 -- A function can never act as a state. If the homonym chain does
33471 -- not contain a corresponding state, then something went wrong in
33472 -- the overloading mechanism.
33474 raise Program_Error
;
33479 ----------------------------
33480 -- Rewrite_Assertion_Kind --
33481 ----------------------------
33483 procedure Rewrite_Assertion_Kind
33485 From_Policy
: Boolean := False)
33491 if Nkind
(N
) = N_Attribute_Reference
33492 and then Attribute_Name
(N
) = Name_Class
33493 and then Nkind
(Prefix
(N
)) = N_Identifier
33495 case Chars
(Prefix
(N
)) is
33502 when Name_Type_Invariant
=>
33503 Nam
:= Name_uType_Invariant
;
33505 when Name_Invariant
=>
33506 Nam
:= Name_uInvariant
;
33512 -- Recommend standard use of aspect names Pre/Post
33514 elsif Nkind
(N
) = N_Identifier
33515 and then From_Policy
33516 and then Serious_Errors_Detected
= 0
33518 if Chars
(N
) = Name_Precondition
33519 or else Chars
(N
) = Name_Postcondition
33521 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
33523 ("\use Assertion_Policy and aspect names Pre/Post for "
33524 & "Ada2012 conformance?", N
);
33530 if Nam
/= No_Name
then
33531 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
33533 end Rewrite_Assertion_Kind
;
33541 Dummy
:= Dummy
+ 1;
33544 --------------------------------
33545 -- Set_Encoded_Interface_Name --
33546 --------------------------------
33548 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
33549 Str
: constant String_Id
:= Strval
(S
);
33550 Len
: constant Nat
:= String_Length
(Str
);
33555 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
33558 -- Stores encoded value of character code CC. The encoding we use an
33559 -- underscore followed by four lower case hex digits.
33565 procedure Encode
is
33567 Store_String_Char
(Get_Char_Code
('_'));
33569 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
33571 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
33573 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
33575 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
33578 -- Start of processing for Set_Encoded_Interface_Name
33581 -- If first character is asterisk, this is a link name, and we leave it
33582 -- completely unmodified. We also ignore null strings (the latter case
33583 -- happens only in error cases).
33586 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
33588 Set_Interface_Name
(E
, S
);
33593 CC
:= Get_String_Char
(Str
, J
);
33595 exit when not In_Character_Range
(CC
);
33597 C
:= Get_Character
(CC
);
33599 exit when C
/= '_' and then C
/= '$'
33600 and then C
not in '0' .. '9'
33601 and then C
not in 'a' .. 'z'
33602 and then C
not in 'A' .. 'Z';
33605 Set_Interface_Name
(E
, S
);
33613 -- Here we need to encode. The encoding we use as follows:
33614 -- three underscores + four hex digits (lower case)
33618 for J
in 1 .. String_Length
(Str
) loop
33619 CC
:= Get_String_Char
(Str
, J
);
33621 if not In_Character_Range
(CC
) then
33624 C
:= Get_Character
(CC
);
33626 if C
= '_' or else C
= '$'
33627 or else C
in '0' .. '9'
33628 or else C
in 'a' .. 'z'
33629 or else C
in 'A' .. 'Z'
33631 Store_String_Char
(CC
);
33638 Set_Interface_Name
(E
,
33639 Make_String_Literal
(Sloc
(S
),
33640 Strval
=> End_String
));
33642 end Set_Encoded_Interface_Name
;
33644 ------------------------
33645 -- Set_Elab_Unit_Name --
33646 ------------------------
33648 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
33653 if Nkind
(N
) = N_Identifier
33654 and then Nkind
(With_Item
) = N_Identifier
33656 Set_Entity
(N
, Entity
(With_Item
));
33658 elsif Nkind
(N
) = N_Selected_Component
then
33659 Change_Selected_Component_To_Expanded_Name
(N
);
33660 Set_Entity
(N
, Entity
(With_Item
));
33661 Set_Entity
(Selector_Name
(N
), Entity
(N
));
33663 Pref
:= Prefix
(N
);
33664 Scop
:= Scope
(Entity
(N
));
33665 while Nkind
(Pref
) = N_Selected_Component
loop
33666 Change_Selected_Component_To_Expanded_Name
(Pref
);
33667 Set_Entity
(Selector_Name
(Pref
), Scop
);
33668 Set_Entity
(Pref
, Scop
);
33669 Pref
:= Prefix
(Pref
);
33670 Scop
:= Scope
(Scop
);
33673 Set_Entity
(Pref
, Scop
);
33676 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
33677 end Set_Elab_Unit_Name
;
33679 -----------------------
33680 -- Set_Overflow_Mode --
33681 -----------------------
33683 procedure Set_Overflow_Mode
(N
: Node_Id
) is
33685 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
;
33686 -- Function to process one pragma argument, Arg
33688 -----------------------
33689 -- Get_Overflow_Mode --
33690 -----------------------
33692 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
is
33693 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
33696 if Chars
(Argx
) = Name_Strict
then
33699 elsif Chars
(Argx
) = Name_Minimized
then
33702 elsif Chars
(Argx
) = Name_Eliminated
then
33706 raise Program_Error
;
33708 end Get_Overflow_Mode
;
33712 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33713 Arg2
: constant Node_Id
:= Next
(Arg1
);
33715 -- Start of processing for Set_Overflow_Mode
33718 -- Process first argument
33720 Scope_Suppress
.Overflow_Mode_General
:=
33721 Get_Overflow_Mode
(Arg1
);
33723 -- Case of only one argument
33726 Scope_Suppress
.Overflow_Mode_Assertions
:=
33727 Scope_Suppress
.Overflow_Mode_General
;
33729 -- Case of two arguments present
33732 Scope_Suppress
.Overflow_Mode_Assertions
:=
33733 Get_Overflow_Mode
(Arg2
);
33735 end Set_Overflow_Mode
;
33737 -------------------
33738 -- Test_Case_Arg --
33739 -------------------
33741 function Test_Case_Arg
33744 From_Aspect
: Boolean := False) return Node_Id
33746 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
33752 (Arg_Nam
in Name_Ensures | Name_Mode | Name_Name | Name_Requires
);
33754 -- The caller requests the aspect argument
33756 if From_Aspect
then
33757 if Present
(Aspect
)
33758 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
33760 Args
:= Expression
(Aspect
);
33762 -- "Name" and "Mode" may appear without an identifier as a
33763 -- positional association.
33765 if Present
(Expressions
(Args
)) then
33766 Arg
:= First
(Expressions
(Args
));
33768 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
33776 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
33781 -- Some or all arguments may appear as component associatons
33783 if Present
(Component_Associations
(Args
)) then
33784 Arg
:= First
(Component_Associations
(Args
));
33785 while Present
(Arg
) loop
33786 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
33795 -- Otherwise retrieve the argument directly from the pragma
33798 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
33800 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
33804 -- Skip argument "Name"
33808 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
33812 -- Skip argument "Mode"
33816 -- Arguments "Requires" and "Ensures" are optional and may not be
33819 while Present
(Arg
) loop
33820 if Chars
(Arg
) = Arg_Nam
then
33831 --------------------------------------------
33832 -- Defer_Compile_Time_Warning_Error_To_BE --
33833 --------------------------------------------
33835 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
) is
33836 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33838 Compile_Time_Warnings_Errors
.Append
33839 (New_Val
=> CTWE_Entry
'(Eloc => Sloc (Arg1),
33840 Scope => Current_Scope,
33843 -- If the Boolean expression contains T'Size, and we're not in the main
33844 -- unit being compiled, then we need to copy the pragma into the main
33845 -- unit, because otherwise T'Size might never be computed, leaving it
33848 if not In_Extended_Main_Code_Unit (N) then
33849 Insert_Library_Level_Action (New_Copy_Tree (N));
33851 end Defer_Compile_Time_Warning_Error_To_BE;
33853 ------------------------------------------
33854 -- Validate_Compile_Time_Warning_Errors --
33855 ------------------------------------------
33857 procedure Validate_Compile_Time_Warning_Errors is
33858 procedure Set_Scope (S : Entity_Id);
33859 -- Install all enclosing scopes of S along with S itself
33861 procedure Unset_Scope (S : Entity_Id);
33862 -- Uninstall all enclosing scopes of S along with S itself
33868 procedure Set_Scope (S : Entity_Id) is
33870 if S /= Standard_Standard then
33871 Set_Scope (Scope (S));
33881 procedure Unset_Scope (S : Entity_Id) is
33883 if S /= Standard_Standard then
33884 Unset_Scope (Scope (S));
33890 -- Start of processing for Validate_Compile_Time_Warning_Errors
33894 -- These error/warning messages were deferred because they could not be
33895 -- evaluated in the front-end and they needed additional information
33896 -- from the back-end. There is no reason to run these checks again if
33897 -- the back-end was not activated by this point.
33899 if not Generating_Code then
33903 Expander_Mode_Save_And_Set (False);
33904 In_Compile_Time_Warning_Or_Error := True;
33906 for N in Compile_Time_Warnings_Errors.First ..
33907 Compile_Time_Warnings_Errors.Last
33910 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
33913 Set_Scope (T.Scope);
33914 Reset_Analyzed_Flags (T.Prag);
33915 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
33916 Unset_Scope (T.Scope);
33920 In_Compile_Time_Warning_Or_Error := False;
33921 Expander_Mode_Restore;
33922 end Validate_Compile_Time_Warning_Errors;