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 -- An external state which has Async_Writers or
2831 -- Effective_Reads enabled cannot appear as a global item
2832 -- of a nonvolatile function (SPARK RM 7.1.3(8)).
2834 elsif Is_External_State
(Item_Id
)
2835 and then (Async_Writers_Enabled
(Item_Id
)
2836 or else Effective_Reads_Enabled
(Item_Id
))
2837 and then Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2838 and then not Is_Volatile_Function
(Spec_Id
)
2841 ("external state & cannot act as global item of "
2842 & "nonvolatile function", Item
, Item_Id
);
2845 -- If the reference to the abstract state appears in an
2846 -- enclosing package body that will eventually refine the
2847 -- state, record the reference for future checks.
2850 Record_Possible_Body_Reference
2851 (State_Id
=> Item_Id
,
2855 -- Constant related checks
2857 elsif Ekind
(Item_Id
) = E_Constant
then
2859 -- Constant is a read-only item, therefore it cannot act as
2862 if Global_Mode
in Name_In_Out | Name_Output
then
2864 -- Constant of an access-to-variable type is a read-write
2865 -- item in procedures, generic procedures, protected
2866 -- entries and tasks.
2868 if Is_Access_Variable
(Etype
(Item_Id
))
2869 and then (Ekind
(Spec_Id
) in E_Entry
2872 | E_Generic_Procedure
2874 or else Is_Single_Task_Object
(Spec_Id
))
2879 ("constant & cannot act as output", Item
, Item_Id
);
2884 -- Loop parameter related checks
2886 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2888 -- A loop parameter is a read-only item, therefore it cannot
2889 -- act as an output.
2891 if Global_Mode
in Name_In_Out | Name_Output
then
2893 ("loop parameter & cannot act as output",
2898 -- Variable related checks. These are only relevant when
2899 -- SPARK_Mode is on as they are not standard Ada legality
2902 elsif SPARK_Mode
= On
2903 and then Ekind
(Item_Id
) = E_Variable
2904 and then Is_Effectively_Volatile_For_Reading
(Item_Id
)
2906 -- The current instance of a protected unit is not an
2907 -- effectively volatile object, unless the protected unit
2908 -- is already volatile for another reason (SPARK RM 7.1.2).
2910 if Is_Single_Protected_Object
(Item_Id
)
2911 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2912 and then not Is_Effectively_Volatile_For_Reading
2913 (Item_Id
, Ignore_Protected
=> True)
2917 -- An effectively volatile object for reading cannot appear
2918 -- as a global item of a nonvolatile function (SPARK RM
2921 elsif Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2922 and then not Is_Volatile_Function
(Spec_Id
)
2925 ("volatile object & cannot act as global item of a "
2926 & "function", Item
, Item_Id
);
2929 -- An effectively volatile object with external property
2930 -- Effective_Reads set to True must have mode Output or
2931 -- In_Out (SPARK RM 7.1.3(10)).
2933 elsif Effective_Reads_Enabled
(Item_Id
)
2934 and then Global_Mode
= Name_Input
2937 ("volatile object & with property Effective_Reads must "
2938 & "have mode In_Out or Output", Item
, Item_Id
);
2943 -- When the item renames an entire object, replace the item
2944 -- with a reference to the object.
2946 if Entity
(Item
) /= Item_Id
then
2947 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2951 -- Some form of illegal construct masquerading as a name
2952 -- (SPARK RM 6.1.4(4)).
2956 ("global item must denote object, state or current instance "
2957 & "of concurrent type", Item
);
2961 -- Verify that an output does not appear as an input in an
2962 -- enclosing subprogram.
2964 if Global_Mode
in Name_In_Out | Name_Output
then
2965 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2968 -- The same entity might be referenced through various way.
2969 -- Check the entity of the item rather than the item itself
2970 -- (SPARK RM 6.1.4(10)).
2972 if Contains
(Seen
, Item_Id
) then
2973 SPARK_Msg_N
("duplicate global item", Item
);
2975 -- Add the entity of the current item to the list of processed
2979 Append_New_Elmt
(Item_Id
, Seen
);
2981 if Ekind
(Item_Id
) = E_Abstract_State
then
2982 Append_New_Elmt
(Item_Id
, States_Seen
);
2984 -- The variable may eventually become a constituent of a single
2985 -- protected/task type. Record the reference now and verify its
2986 -- legality when analyzing the contract of the variable
2989 elsif Ekind
(Item_Id
) = E_Variable
then
2990 Record_Possible_Part_Of_Reference
2995 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
2996 and then Present
(Encapsulating_State
(Item_Id
))
2998 Append_New_Elmt
(Item_Id
, Constits_Seen
);
3001 end Analyze_Global_Item
;
3003 --------------------------
3004 -- Check_Duplicate_Mode --
3005 --------------------------
3007 procedure Check_Duplicate_Mode
3009 Status
: in out Boolean)
3013 SPARK_Msg_N
("duplicate global mode", Mode
);
3017 end Check_Duplicate_Mode
;
3019 -------------------------------------------------
3020 -- Check_Mode_Restriction_In_Enclosing_Context --
3021 -------------------------------------------------
3023 procedure Check_Mode_Restriction_In_Enclosing_Context
3025 Item_Id
: Entity_Id
)
3027 Context
: Entity_Id
;
3029 Inputs
: Elist_Id
:= No_Elist
;
3030 Outputs
: Elist_Id
:= No_Elist
;
3033 -- Traverse the scope stack looking for enclosing subprograms or
3034 -- tasks subject to pragma [Refined_]Global.
3036 Context
:= Scope
(Subp_Id
);
3037 while Present
(Context
) and then Context
/= Standard_Standard
loop
3039 -- For a single task type, retrieve the corresponding object to
3040 -- which pragma [Refined_]Global is attached.
3042 if Ekind
(Context
) = E_Task_Type
3043 and then Is_Single_Concurrent_Type
(Context
)
3045 Context
:= Anonymous_Object
(Context
);
3048 if Is_Subprogram_Or_Entry
(Context
)
3049 or else Ekind
(Context
) = E_Task_Type
3050 or else Is_Single_Task_Object
(Context
)
3052 Collect_Subprogram_Inputs_Outputs
3053 (Subp_Id
=> Context
,
3054 Subp_Inputs
=> Inputs
,
3055 Subp_Outputs
=> Outputs
,
3056 Global_Seen
=> Dummy
);
3058 -- The item is classified as In_Out or Output but appears as
3059 -- an Input or a formal parameter of mode IN in an enclosing
3060 -- subprogram or task unit (SPARK RM 6.1.4(13)).
3062 if Appears_In
(Inputs
, Item_Id
)
3063 and then not Appears_In
(Outputs
, Item_Id
)
3066 ("global item & cannot have mode In_Out or Output",
3069 if Is_Subprogram_Or_Entry
(Context
) then
3071 (Fix_Msg
(Subp_Id
, "\item already appears as input "
3072 & "of subprogram &"), Item
, Context
);
3075 (Fix_Msg
(Subp_Id
, "\item already appears as input "
3076 & "of task &"), Item
, Context
);
3079 -- Stop the traversal once an error has been detected
3085 Context
:= Scope
(Context
);
3087 end Check_Mode_Restriction_In_Enclosing_Context
;
3089 ----------------------------------------
3090 -- Check_Mode_Restriction_In_Function --
3091 ----------------------------------------
3093 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
3095 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
3096 and then not Is_Function_With_Side_Effects
(Spec_Id
)
3098 Error_Msg_Code
:= GEC_Output_In_Function_Global_Or_Depends
;
3100 ("global mode & is not applicable to function '[[]']", Mode
);
3102 end Check_Mode_Restriction_In_Function
;
3110 -- Start of processing for Analyze_Global_List
3113 if Nkind
(List
) = N_Null
then
3114 Set_Analyzed
(List
);
3116 -- Single global item declaration
3118 elsif Nkind
(List
) in N_Expanded_Name
3120 | N_Selected_Component
3122 Analyze_Global_Item
(List
, Global_Mode
);
3124 -- Simple global list or moded global list declaration
3126 elsif Nkind
(List
) = N_Aggregate
then
3127 Set_Analyzed
(List
);
3129 -- The declaration of a simple global list appear as a collection
3132 if Present
(Expressions
(List
)) then
3133 if Present
(Component_Associations
(List
)) then
3135 ("cannot mix moded and non-moded global lists", List
);
3138 Item
:= First
(Expressions
(List
));
3139 while Present
(Item
) loop
3140 Analyze_Global_Item
(Item
, Global_Mode
);
3144 -- The declaration of a moded global list appears as a collection
3145 -- of component associations where individual choices denote
3148 elsif Present
(Component_Associations
(List
)) then
3149 if Present
(Expressions
(List
)) then
3151 ("cannot mix moded and non-moded global lists", List
);
3154 Assoc
:= First
(Component_Associations
(List
));
3155 while Present
(Assoc
) loop
3156 Mode
:= First
(Choices
(Assoc
));
3158 if Nkind
(Mode
) = N_Identifier
then
3159 if Chars
(Mode
) = Name_In_Out
then
3160 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
3161 Check_Mode_Restriction_In_Function
(Mode
);
3163 elsif Chars
(Mode
) = Name_Input
then
3164 Check_Duplicate_Mode
(Mode
, Input_Seen
);
3166 elsif Chars
(Mode
) = Name_Output
then
3167 Check_Duplicate_Mode
(Mode
, Output_Seen
);
3168 Check_Mode_Restriction_In_Function
(Mode
);
3170 elsif Chars
(Mode
) = Name_Proof_In
then
3171 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
3174 SPARK_Msg_N
("invalid mode selector", Mode
);
3178 SPARK_Msg_N
("invalid mode selector", Mode
);
3181 -- Items in a moded list appear as a collection of
3182 -- expressions. Reuse the existing machinery to analyze
3186 (List
=> Expression
(Assoc
),
3187 Global_Mode
=> Chars
(Mode
));
3195 raise Program_Error
;
3198 -- Any other attempt to declare a global item is illegal. This is a
3199 -- syntax error, always report.
3202 Error_Msg_N
("malformed global list", List
);
3204 end Analyze_Global_List
;
3208 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
3210 Restore_Scope
: Boolean := False;
3212 -- Start of processing for Analyze_Global_In_Decl_Part
3215 -- Do not analyze the pragma multiple times
3217 if Is_Analyzed_Pragma
(N
) then
3221 -- There is nothing to be done for a null global list
3223 if Nkind
(Items
) = N_Null
then
3224 Set_Analyzed
(Items
);
3226 -- Analyze the various forms of global lists and items. Note that some
3227 -- of these may be malformed in which case the analysis emits error
3231 -- When pragma [Refined_]Global appears on a single concurrent type,
3232 -- it is relocated to the anonymous object.
3234 if Is_Single_Concurrent_Object
(Spec_Id
) then
3237 -- Ensure that the formal parameters are visible when processing an
3238 -- item. This falls out of the general rule of aspects pertaining to
3239 -- subprogram declarations.
3241 elsif not In_Open_Scopes
(Spec_Id
) then
3242 Restore_Scope
:= True;
3243 Push_Scope
(Spec_Id
);
3245 if Ekind
(Spec_Id
) = E_Task_Type
then
3247 -- Task discriminants cannot appear in the [Refined_]Global
3248 -- contract, but must be present for the analysis so that we
3249 -- can reject them with an informative error message.
3251 if Has_Discriminants
(Spec_Id
) then
3252 Install_Discriminants
(Spec_Id
);
3255 elsif Is_Generic_Subprogram
(Spec_Id
) then
3256 Install_Generic_Formals
(Spec_Id
);
3259 Install_Formals
(Spec_Id
);
3263 Analyze_Global_List
(Items
);
3265 if Restore_Scope
then
3270 -- Ensure that a state and a corresponding constituent do not appear
3271 -- together in pragma [Refined_]Global.
3273 Check_State_And_Constituent_Use
3274 (States
=> States_Seen
,
3275 Constits
=> Constits_Seen
,
3278 Set_Is_Analyzed_Pragma
(N
);
3279 end Analyze_Global_In_Decl_Part
;
3281 ---------------------------------
3282 -- Analyze_If_Present_Internal --
3283 ---------------------------------
3285 procedure Analyze_If_Present_Internal
3293 pragma Assert
(Is_List_Member
(N
));
3295 -- Inspect the declarations or statements following pragma N looking
3296 -- for another pragma whose Id matches the caller's request. If it is
3297 -- available, analyze it.
3305 while Present
(Stmt
) loop
3306 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
3307 Analyze_Pragma
(Stmt
);
3310 -- The first source declaration or statement immediately following
3311 -- N ends the region where a pragma may appear.
3313 elsif Comes_From_Source
(Stmt
) then
3319 end Analyze_If_Present_Internal
;
3321 --------------------------------------------
3322 -- Analyze_Initial_Condition_In_Decl_Part --
3323 --------------------------------------------
3325 -- WARNING: This routine manages Ghost regions. Return statements must be
3326 -- replaced by gotos which jump to the end of the routine and restore the
3329 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
3330 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3331 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3332 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3334 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
3335 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
3336 -- Save the Ghost-related attributes to restore on exit
3339 -- Do not analyze the pragma multiple times
3341 if Is_Analyzed_Pragma
(N
) then
3345 -- Set the Ghost mode in effect from the pragma. Due to the delayed
3346 -- analysis of the pragma, the Ghost mode at point of declaration and
3347 -- point of analysis may not necessarily be the same. Use the mode in
3348 -- effect at the point of declaration.
3352 -- The expression is preanalyzed because it has not been moved to its
3353 -- final place yet. A direct analysis may generate side effects and this
3354 -- is not desired at this point.
3356 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
3357 Set_Is_Analyzed_Pragma
(N
);
3359 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
3360 end Analyze_Initial_Condition_In_Decl_Part
;
3362 --------------------------------------
3363 -- Analyze_Initializes_In_Decl_Part --
3364 --------------------------------------
3366 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
3367 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3368 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3370 Constits_Seen
: Elist_Id
:= No_Elist
;
3371 -- A list containing the entities of all constituents processed so far.
3372 -- It aids in detecting illegal usage of a state and a corresponding
3373 -- constituent in pragma Initializes.
3375 Items_Seen
: Elist_Id
:= No_Elist
;
3376 -- A list of all initialization items processed so far. This list is
3377 -- used to detect duplicate items.
3379 States_And_Objs
: Elist_Id
:= No_Elist
;
3380 -- A list of all abstract states and objects declared in the visible
3381 -- declarations of the related package. This list is used to detect the
3382 -- legality of initialization items.
3384 States_Seen
: Elist_Id
:= No_Elist
;
3385 -- A list containing the entities of all states processed so far. It
3386 -- helps in detecting illegal usage of a state and a corresponding
3387 -- constituent in pragma Initializes.
3389 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
3390 -- Verify the legality of a single initialization item
3392 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
3393 -- Verify the legality of a single initialization item followed by a
3394 -- list of input items.
3396 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
);
3397 -- Inspect the visible declarations of the related package and gather
3398 -- the entities of all abstract states and objects in States_And_Objs.
3400 ---------------------------------
3401 -- Analyze_Initialization_Item --
3402 ---------------------------------
3404 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
3405 Item_Id
: Entity_Id
;
3409 Resolve_State
(Item
);
3411 if Is_Entity_Name
(Item
) then
3412 Item_Id
:= Entity_Of
(Item
);
3414 if Present
(Item_Id
)
3415 and then Ekind
(Item_Id
) in
3416 E_Abstract_State | E_Constant | E_Variable
3418 -- When the initialization item is undefined, it appears as
3419 -- Any_Id. Do not continue with the analysis of the item.
3421 if Item_Id
= Any_Id
then
3424 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
3425 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
3428 ("overlaying object & cannot appear in Initializes",
3431 ("\use the overlaid object & instead",
3432 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
3434 -- The state or variable must be declared in the visible
3435 -- declarations of the package (SPARK RM 7.1.5(7)).
3437 elsif not Contains
(States_And_Objs
, Item_Id
) then
3438 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3440 ("initialization item & must appear in the visible "
3441 & "declarations of package %", Item
, Item_Id
);
3443 -- Detect a duplicate use of the same initialization item
3444 -- (SPARK RM 7.1.5(5)).
3446 elsif Contains
(Items_Seen
, Item_Id
) then
3447 SPARK_Msg_N
("duplicate initialization item", Item
);
3449 -- The item is legal, add it to the list of processed states
3453 Append_New_Elmt
(Item_Id
, Items_Seen
);
3455 if Ekind
(Item_Id
) = E_Abstract_State
then
3456 Append_New_Elmt
(Item_Id
, States_Seen
);
3459 if Present
(Encapsulating_State
(Item_Id
)) then
3460 Append_New_Elmt
(Item_Id
, Constits_Seen
);
3464 -- The item references something that is not a state or object
3465 -- (SPARK RM 7.1.5(3)).
3469 ("initialization item must denote object or state", Item
);
3472 -- Some form of illegal construct masquerading as a name
3473 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3477 ("initialization item must denote object or state", Item
);
3479 end Analyze_Initialization_Item
;
3481 ---------------------------------------------
3482 -- Analyze_Initialization_Item_With_Inputs --
3483 ---------------------------------------------
3485 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
3486 Inputs_Seen
: Elist_Id
:= No_Elist
;
3487 -- A list of all inputs processed so far. This list is used to detect
3488 -- duplicate uses of an input.
3490 Non_Null_Seen
: Boolean := False;
3491 Null_Seen
: Boolean := False;
3492 -- Flags used to check the legality of an input list
3494 procedure Analyze_Input_Item
(Input
: Node_Id
);
3495 -- Verify the legality of a single input item
3497 ------------------------
3498 -- Analyze_Input_Item --
3499 ------------------------
3501 procedure Analyze_Input_Item
(Input
: Node_Id
) is
3502 Input_Id
: Entity_Id
;
3507 if Nkind
(Input
) = N_Null
then
3510 ("multiple null initializations not allowed", Item
);
3512 elsif Non_Null_Seen
then
3514 ("cannot mix null and non-null initialization item", Item
);
3522 Non_Null_Seen
:= True;
3526 ("cannot mix null and non-null initialization item", Item
);
3530 Resolve_State
(Input
);
3532 if Is_Entity_Name
(Input
) then
3533 Input_Id
:= Entity_Of
(Input
);
3535 if Present
(Input_Id
)
3536 and then Ekind
(Input_Id
) in E_Abstract_State
3538 | E_Generic_In_Out_Parameter
3539 | E_Generic_In_Parameter
3541 | E_In_Out_Parameter
3547 -- The input cannot denote states or objects declared
3548 -- within the related package (SPARK RM 7.1.5(4)).
3550 if Within_Scope
(Input_Id
, Current_Scope
) then
3552 -- Do not consider generic formal parameters or their
3553 -- respective mappings to generic formals. Even though
3554 -- the formals appear within the scope of the package,
3555 -- it is allowed for an initialization item to depend
3556 -- on an input item.
3558 if Is_Formal_Object
(Input_Id
) then
3561 elsif Ekind
(Input_Id
) in E_Constant | E_Variable
3562 and then Present
(Corresponding_Generic_Association
3563 (Declaration_Node
(Input_Id
)))
3568 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3570 ("input item & cannot denote a visible object or "
3571 & "state of package %", Input
, Input_Id
);
3576 if Ekind
(Input_Id
) in E_Constant | E_Variable
3577 and then Present
(Ultimate_Overlaid_Entity
(Input_Id
))
3580 ("overlaying object & cannot appear in Initializes",
3583 ("\use the overlaid object & instead",
3584 Input
, Ultimate_Overlaid_Entity
(Input_Id
));
3588 -- Detect a duplicate use of the same input item
3589 -- (SPARK RM 7.1.5(5)).
3591 if Contains
(Inputs_Seen
, Input_Id
) then
3592 SPARK_Msg_N
("duplicate input item", Input
);
3596 -- At this point it is known that the input is legal. Add
3597 -- it to the list of processed inputs.
3599 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
3601 if Ekind
(Input_Id
) = E_Abstract_State
then
3602 Append_New_Elmt
(Input_Id
, States_Seen
);
3605 if Ekind
(Input_Id
) in E_Abstract_State
3608 and then Present
(Encapsulating_State
(Input_Id
))
3610 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3613 -- The input references something that is not a state or an
3614 -- object (SPARK RM 7.1.5(3)).
3618 ("input item must denote object or state", Input
);
3621 -- Some form of illegal construct masquerading as a name
3622 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3626 ("input item must denote object or state", Input
);
3629 end Analyze_Input_Item
;
3633 Inputs
: constant Node_Id
:= Expression
(Item
);
3637 Name_Seen
: Boolean := False;
3638 -- A flag used to detect multiple item names
3640 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3643 -- Inspect the name of an item with inputs
3645 Elmt
:= First
(Choices
(Item
));
3646 while Present
(Elmt
) loop
3648 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3651 Analyze_Initialization_Item
(Elmt
);
3657 -- Multiple input items appear as an aggregate
3659 if Nkind
(Inputs
) = N_Aggregate
then
3660 if Present
(Expressions
(Inputs
)) then
3661 Input
:= First
(Expressions
(Inputs
));
3662 while Present
(Input
) loop
3663 Analyze_Input_Item
(Input
);
3668 if Present
(Component_Associations
(Inputs
)) then
3670 ("inputs must appear in named association form", Inputs
);
3673 -- Single input item
3676 Analyze_Input_Item
(Inputs
);
3678 end Analyze_Initialization_Item_With_Inputs
;
3680 --------------------------------
3681 -- Collect_States_And_Objects --
3682 --------------------------------
3684 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
) is
3685 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3686 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3688 State_Elmt
: Elmt_Id
;
3691 -- Collect the abstract states defined in the package (if any)
3693 if Has_Non_Null_Abstract_State
(Pack_Id
) then
3694 State_Elmt
:= First_Elmt
(Abstract_States
(Pack_Id
));
3695 while Present
(State_Elmt
) loop
3696 Append_New_Elmt
(Node
(State_Elmt
), States_And_Objs
);
3697 Next_Elmt
(State_Elmt
);
3701 -- Collect all objects that appear in the visible declarations of the
3704 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3705 while Present
(Decl
) loop
3706 if Comes_From_Source
(Decl
)
3707 and then Nkind
(Decl
) in N_Object_Declaration
3708 | N_Object_Renaming_Declaration
3710 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3712 elsif Nkind
(Decl
) = N_Package_Declaration
then
3713 Collect_States_And_Objects
(Decl
);
3715 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3717 (Anonymous_Object
(Defining_Entity
(Decl
)),
3723 end Collect_States_And_Objects
;
3727 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3730 -- Start of processing for Analyze_Initializes_In_Decl_Part
3733 -- Do not analyze the pragma multiple times
3735 if Is_Analyzed_Pragma
(N
) then
3739 -- Nothing to do when the initialization list is empty
3741 if Nkind
(Inits
) = N_Null
then
3745 -- Single and multiple initialization clauses appear as an aggregate. If
3746 -- this is not the case, then either the parser or the analysis of the
3747 -- pragma failed to produce an aggregate.
3749 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3751 -- Initialize the various lists used during analysis
3753 Collect_States_And_Objects
(Pack_Decl
);
3755 if Present
(Expressions
(Inits
)) then
3756 Init
:= First
(Expressions
(Inits
));
3757 while Present
(Init
) loop
3758 Analyze_Initialization_Item
(Init
);
3763 if Present
(Component_Associations
(Inits
)) then
3764 Init
:= First
(Component_Associations
(Inits
));
3765 while Present
(Init
) loop
3766 Analyze_Initialization_Item_With_Inputs
(Init
);
3771 -- Ensure that a state and a corresponding constituent do not appear
3772 -- together in pragma Initializes.
3774 Check_State_And_Constituent_Use
3775 (States
=> States_Seen
,
3776 Constits
=> Constits_Seen
,
3779 Set_Is_Analyzed_Pragma
(N
);
3780 end Analyze_Initializes_In_Decl_Part
;
3782 ---------------------
3783 -- Analyze_Part_Of --
3784 ---------------------
3786 procedure Analyze_Part_Of
3788 Item_Id
: Entity_Id
;
3790 Encap_Id
: out Entity_Id
;
3791 Legal
: out Boolean)
3793 procedure Check_Part_Of_Abstract_State
;
3794 pragma Inline
(Check_Part_Of_Abstract_State
);
3795 -- Verify the legality of indicator Part_Of when the encapsulator is an
3798 procedure Check_Part_Of_Concurrent_Type
;
3799 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3800 -- Verify the legality of indicator Part_Of when the encapsulator is a
3801 -- single concurrent type.
3803 ----------------------------------
3804 -- Check_Part_Of_Abstract_State --
3805 ----------------------------------
3807 procedure Check_Part_Of_Abstract_State
is
3808 Pack_Id
: Entity_Id
;
3809 Placement
: State_Space_Kind
;
3810 Parent_Unit
: Entity_Id
;
3813 -- Determine where the object, package instantiation or state lives
3814 -- with respect to the enclosing packages or package bodies.
3816 Find_Placement_In_State_Space
3817 (Item_Id
=> Item_Id
,
3818 Placement
=> Placement
,
3819 Pack_Id
=> Pack_Id
);
3821 -- The item appears in a non-package construct with a declarative
3822 -- part (subprogram, block, etc). As such, the item is not allowed
3823 -- to be a part of an encapsulating state because the item is not
3826 if Placement
= Not_In_Package
then
3828 ("indicator Part_Of cannot appear in this context "
3829 & "(SPARK RM 7.2.6(5))", Indic
);
3831 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3833 ("\& is not part of the hidden state of package %",
3837 -- The item appears in the visible state space of some package. In
3838 -- general this scenario does not warrant Part_Of except when the
3839 -- package is a nongeneric private child unit and the encapsulating
3840 -- state is declared in a parent unit or a public descendant of that
3843 elsif Placement
= Visible_State_Space
then
3844 if Is_Child_Unit
(Pack_Id
)
3845 and then not Is_Generic_Unit
(Pack_Id
)
3846 and then Is_Private_Descendant
(Pack_Id
)
3848 -- A variable or state abstraction which is part of the visible
3849 -- state of a nongeneric private child unit or its public
3850 -- descendants must have its Part_Of indicator specified. The
3851 -- Part_Of indicator must denote a state declared by either the
3852 -- parent unit of the private unit or by a public descendant of
3853 -- that parent unit.
3855 -- Find the nearest private ancestor (which can be the current
3858 Parent_Unit
:= Pack_Id
;
3859 while Present
(Parent_Unit
) loop
3860 exit when Is_Private_Library_Unit
(Parent_Unit
);
3861 Parent_Unit
:= Scope
(Parent_Unit
);
3864 Parent_Unit
:= Scope
(Parent_Unit
);
3866 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3868 ("indicator Part_Of must denote abstract state of & or of "
3869 & "its public descendant (SPARK RM 7.2.6(3))",
3870 Indic
, Parent_Unit
);
3873 elsif Scope
(Encap_Id
) = Parent_Unit
3875 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3876 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3882 ("indicator Part_Of must denote abstract state of & or of "
3883 & "its public descendant (SPARK RM 7.2.6(3))",
3884 Indic
, Parent_Unit
);
3888 -- Indicator Part_Of is not needed when the related package is
3889 -- not a nongeneric private child unit or a public descendant
3894 ("indicator Part_Of cannot appear in this context "
3895 & "(SPARK RM 7.2.6(5))", Indic
);
3897 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3899 ("\& is declared in the visible part of package %",
3904 -- When the item appears in the private state space of a package, the
3905 -- encapsulating state must be declared in the same package.
3907 elsif Placement
= Private_State_Space
then
3909 -- In the case of the abstract state of a nongeneric private
3910 -- child package, it may be encapsulated in the state of a
3911 -- public descendant of its parent package.
3914 function Is_Public_Descendant
3915 (Child
, Ancestor
: Entity_Id
)
3917 -- Return True if Child is a public descendant of Pack
3919 --------------------------
3920 -- Is_Public_Descendant --
3921 --------------------------
3923 function Is_Public_Descendant
3924 (Child
, Ancestor
: Entity_Id
)
3927 P
: Entity_Id
:= Child
;
3929 while Is_Child_Unit
(P
)
3930 and then not Is_Private_Library_Unit
(P
)
3932 if Scope
(P
) = Ancestor
then
3940 end Is_Public_Descendant
;
3944 Immediate_Pack_Id
: constant Entity_Id
:= Scope
(Item_Id
);
3946 Is_State_Of_Private_Child
: constant Boolean :=
3947 Is_Child_Unit
(Immediate_Pack_Id
)
3948 and then not Is_Generic_Unit
(Immediate_Pack_Id
)
3949 and then Is_Private_Descendant
(Immediate_Pack_Id
);
3951 Is_OK_Through_Sibling
: Boolean := False;
3954 if Ekind
(Item_Id
) = E_Abstract_State
3955 and then Is_State_Of_Private_Child
3956 and then Is_Public_Descendant
(Scope
(Encap_Id
), Pack_Id
)
3958 Is_OK_Through_Sibling
:= True;
3961 if Scope
(Encap_Id
) /= Pack_Id
3962 and then not Is_OK_Through_Sibling
3964 if Is_State_Of_Private_Child
then
3966 ("indicator Part_Of must denote abstract state of & "
3967 & "or of its public descendant "
3968 & "(SPARK RM 7.2.6(3))", Indic
, Pack_Id
);
3971 ("indicator Part_Of must denote an abstract state of "
3972 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3975 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3977 ("\& is declared in the private part of package %",
3983 -- Items declared in the body state space of a package do not need
3984 -- Part_Of indicators as the refinement has already been seen.
3988 ("indicator Part_Of cannot appear in this context "
3989 & "(SPARK RM 7.2.6(5))", Indic
);
3991 if Scope
(Encap_Id
) = Pack_Id
then
3992 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3994 ("\& is declared in the body of package %", Indic
, Item_Id
);
4000 -- In the case of state in a (descendant of a private) child which
4001 -- is Part_Of the state of another package, the package defining the
4002 -- encapsulating abstract state should have a body, to ensure that it
4003 -- has a state refinement (SPARK RM 7.1.4(4)).
4005 if Enclosing_Comp_Unit_Node
(Encap_Id
) /=
4006 Enclosing_Comp_Unit_Node
(Item_Id
)
4007 and then not Unit_Requires_Body
(Scope
(Encap_Id
))
4010 ("indicator Part_Of must denote abstract state of package "
4011 & "with a body (SPARK RM 7.1.4(4))", Indic
);
4015 -- At this point it is known that the Part_Of indicator is legal
4018 end Check_Part_Of_Abstract_State
;
4020 -----------------------------------
4021 -- Check_Part_Of_Concurrent_Type --
4022 -----------------------------------
4024 procedure Check_Part_Of_Concurrent_Type
is
4025 function In_Proper_Order
4027 Second
: Node_Id
) return Boolean;
4028 pragma Inline
(In_Proper_Order
);
4029 -- Determine whether node First precedes node Second
4031 procedure Placement_Error
;
4032 pragma Inline
(Placement_Error
);
4033 -- Emit an error concerning the illegal placement of the item with
4034 -- respect to the single concurrent type.
4036 ---------------------
4037 -- In_Proper_Order --
4038 ---------------------
4040 function In_Proper_Order
4042 Second
: Node_Id
) return Boolean
4047 if List_Containing
(First
) = List_Containing
(Second
) then
4049 while Present
(N
) loop
4059 end In_Proper_Order
;
4061 ---------------------
4062 -- Placement_Error --
4063 ---------------------
4065 procedure Placement_Error
is
4068 ("indicator Part_Of must denote a previously declared single "
4069 & "protected type or single task type", Encap
);
4070 end Placement_Error
;
4074 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
4075 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
4076 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
4078 Item_Context
: Node_Id
;
4079 Item_Decl
: Node_Id
;
4080 Prv_Decls
: List_Id
;
4081 Vis_Decls
: List_Id
;
4083 -- Start of processing for Check_Part_Of_Concurrent_Type
4086 -- Only abstract states and variables can act as constituents of an
4087 -- encapsulating single concurrent type.
4089 if Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
4092 -- The constituent is a constant
4094 elsif Ekind
(Item_Id
) = E_Constant
then
4095 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4097 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
4098 & "single protected type %"), Indic
, Item_Id
);
4101 -- The constituent is a package instantiation
4104 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4106 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
4107 & "constituent of single protected type %"), Indic
, Item_Id
);
4111 -- When the item denotes an abstract state of a nested package, use
4112 -- the declaration of the package to detect proper placement.
4117 -- with Abstract_State => (State with Part_Of => T)
4119 if Ekind
(Item_Id
) = E_Abstract_State
then
4120 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
4122 Item_Decl
:= Declaration_Node
(Item_Id
);
4125 Item_Context
:= Parent
(Item_Decl
);
4127 -- The item and the single concurrent type must appear in the same
4128 -- declarative region, with the item following the declaration of
4129 -- the single concurrent type (SPARK RM 9(3)).
4131 if Item_Context
= Encap_Context
then
4132 if Nkind
(Item_Context
) in N_Package_Specification
4133 | N_Protected_Definition
4136 Prv_Decls
:= Private_Declarations
(Item_Context
);
4137 Vis_Decls
:= Visible_Declarations
(Item_Context
);
4139 -- The placement is OK when the single concurrent type appears
4140 -- within the visible declarations and the item in the private
4146 -- Constit : ... with Part_Of => PO;
4149 if List_Containing
(Encap_Decl
) = Vis_Decls
4150 and then List_Containing
(Item_Decl
) = Prv_Decls
4154 -- The placement is illegal when the item appears within the
4155 -- visible declarations and the single concurrent type is in
4156 -- the private declarations.
4159 -- Constit : ... with Part_Of => PO;
4164 elsif List_Containing
(Item_Decl
) = Vis_Decls
4165 and then List_Containing
(Encap_Decl
) = Prv_Decls
4170 -- Otherwise both the item and the single concurrent type are
4171 -- in the same list. Ensure that the declaration of the single
4172 -- concurrent type precedes that of the item.
4174 elsif not In_Proper_Order
4175 (First
=> Encap_Decl
,
4176 Second
=> Item_Decl
)
4182 -- Otherwise both the item and the single concurrent type are
4183 -- in the same list. Ensure that the declaration of the single
4184 -- concurrent type precedes that of the item.
4186 elsif not In_Proper_Order
4187 (First
=> Encap_Decl
,
4188 Second
=> Item_Decl
)
4194 -- Otherwise the item and the single concurrent type reside within
4195 -- unrelated regions.
4198 Error_Msg_Name_1
:= Chars
(Encap_Id
);
4200 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
4201 & "immediately within the same region as single protected "
4202 & "type %"), Indic
, Item_Id
);
4206 -- At this point it is known that the Part_Of indicator is legal
4209 end Check_Part_Of_Concurrent_Type
;
4211 -- Start of processing for Analyze_Part_Of
4214 -- Assume that the indicator is illegal
4220 N_Expanded_Name | N_Identifier | N_Selected_Component
4223 Resolve_State
(Encap
);
4225 Encap_Id
:= Entity
(Encap
);
4227 -- The encapsulator is an abstract state
4229 if Ekind
(Encap_Id
) = E_Abstract_State
then
4232 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
4234 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
4237 -- Otherwise the encapsulator is not a legal choice
4241 ("indicator Part_Of must denote abstract state, single "
4242 & "protected type or single task type", Encap
);
4246 -- This is a syntax error, always report
4250 ("indicator Part_Of must denote abstract state, single protected "
4251 & "type or single task type", Encap
);
4255 -- Catch a case where indicator Part_Of denotes the abstract view of a
4256 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
4258 if From_Limited_With
(Encap_Id
)
4259 and then Present
(Non_Limited_View
(Encap_Id
))
4260 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
4262 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
4263 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
4267 -- The encapsulator is an abstract state
4269 if Ekind
(Encap_Id
) = E_Abstract_State
then
4270 Check_Part_Of_Abstract_State
;
4272 -- The encapsulator is a single concurrent type
4275 Check_Part_Of_Concurrent_Type
;
4277 end Analyze_Part_Of
;
4279 ----------------------------------
4280 -- Analyze_Part_Of_In_Decl_Part --
4281 ----------------------------------
4283 procedure Analyze_Part_Of_In_Decl_Part
4285 Freeze_Id
: Entity_Id
:= Empty
)
4287 Encap
: constant Node_Id
:=
4288 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
4289 Errors
: constant Nat
:= Serious_Errors_Detected
;
4290 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
4291 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
4292 Constits
: Elist_Id
;
4293 Encap_Id
: Entity_Id
;
4297 -- Detect any discrepancies between the placement of the variable with
4298 -- respect to general state space and the encapsulating state or single
4305 Encap_Id
=> Encap_Id
,
4308 -- The Part_Of indicator turns the variable into a constituent of the
4309 -- encapsulating state or single concurrent type.
4312 pragma Assert
(Present
(Encap_Id
));
4313 Constits
:= Part_Of_Constituents
(Encap_Id
);
4315 if No
(Constits
) then
4316 Constits
:= New_Elmt_List
;
4317 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
4320 Append_Elmt
(Var_Id
, Constits
);
4321 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
4323 -- A Part_Of constituent partially refines an abstract state. This
4324 -- property does not apply to protected or task units.
4326 if Ekind
(Encap_Id
) = E_Abstract_State
then
4327 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
4331 -- Emit a clarification message when the encapsulator is undefined,
4332 -- possibly due to contract freezing.
4334 if Errors
/= Serious_Errors_Detected
4335 and then Present
(Freeze_Id
)
4336 and then Has_Undefined_Reference
(Encap
)
4338 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
4340 end Analyze_Part_Of_In_Decl_Part
;
4342 --------------------
4343 -- Analyze_Pragma --
4344 --------------------
4346 procedure Analyze_Pragma
(N
: Node_Id
) is
4347 Loc
: constant Source_Ptr
:= Sloc
(N
);
4349 Pname
: Name_Id
:= Pragma_Name
(N
);
4350 -- Name of the source pragma, or name of the corresponding aspect for
4351 -- pragmas which originate in a source aspect. In the latter case, the
4352 -- name may be different from the pragma name.
4354 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
4356 Pragma_Exit
: exception;
4357 -- This exception is used to exit pragma processing completely. It
4358 -- is used when an error is detected, and no further processing is
4359 -- required. It is also used if an earlier error has left the tree in
4360 -- a state where the pragma should not be processed.
4363 -- Number of pragma argument associations
4370 -- First five pragma arguments (pragma argument association nodes, or
4371 -- Empty if the corresponding argument does not exist).
4373 type Name_List
is array (Natural range <>) of Name_Id
;
4374 type Args_List
is array (Natural range <>) of Node_Id
;
4375 -- Types used for arguments to Check_Arg_Order and Gather_Associations
4377 -----------------------
4378 -- Local Subprograms --
4379 -----------------------
4381 procedure Ada_2005_Pragma
;
4382 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
4383 -- Ada 95 mode, these are implementation defined pragmas, so should be
4384 -- caught by the No_Implementation_Pragmas restriction.
4386 procedure Ada_2012_Pragma
;
4387 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
4388 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
4389 -- should be caught by the No_Implementation_Pragmas restriction.
4391 procedure Analyze_Depends_Global
4392 (Spec_Id
: out Entity_Id
;
4393 Subp_Decl
: out Node_Id
;
4394 Legal
: out Boolean);
4395 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
4396 -- legality of the placement and related context of the pragma. Spec_Id
4397 -- is the entity of the related subprogram. Subp_Decl is the declaration
4398 -- of the related subprogram. Sets flag Legal when the pragma is legal.
4400 procedure Analyze_If_Present
(Id
: Pragma_Id
);
4401 -- Inspect the remainder of the list containing pragma N and look for
4402 -- a pragma that matches Id. If found, analyze the pragma.
4404 procedure Analyze_Pre_Post_Condition
;
4405 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
4407 procedure Analyze_Refined_Depends_Global_Post
4408 (Spec_Id
: out Entity_Id
;
4409 Body_Id
: out Entity_Id
;
4410 Legal
: out Boolean);
4411 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
4412 -- Refined_Global and Refined_Post. Verify the legality of the placement
4413 -- and related context of the pragma. Spec_Id is the entity of the
4414 -- related subprogram. Body_Id is the entity of the subprogram body.
4415 -- Flag Legal is set when the pragma is legal.
4417 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
4418 -- Perform full analysis of pragma Unmodified and the write aspect of
4419 -- pragma Unused. Flag Is_Unused should be set when verifying the
4420 -- semantics of pragma Unused.
4422 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
4423 -- Perform full analysis of pragma Unreferenced and the read aspect of
4424 -- pragma Unused. Flag Is_Unused should be set when verifying the
4425 -- semantics of pragma Unused.
4427 procedure Check_Ada_83_Warning
;
4428 -- Issues a warning message for the current pragma if operating in Ada
4429 -- 83 mode (used for language pragmas that are not a standard part of
4430 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
4433 procedure Check_Arg_Count
(Required
: Nat
);
4434 -- Check argument count for pragma is equal to given parameter. If not,
4435 -- then issue an error message and raise Pragma_Exit.
4437 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
4438 -- Arg which can either be a pragma argument association, in which case
4439 -- the check is applied to the expression of the association or an
4440 -- expression directly.
4442 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
4443 -- Check that an argument has the right form for an EXTERNAL_NAME
4444 -- parameter of an extended import/export pragma. The rule is that the
4445 -- name must be an identifier or string literal (in Ada 83 mode) or a
4446 -- static string expression (in Ada 95 mode).
4448 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
4449 -- Check the specified argument Arg to make sure that it is an
4450 -- identifier. If not give error and raise Pragma_Exit.
4452 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
4453 -- Check the specified argument Arg to make sure that it is an integer
4454 -- literal. If not give error and raise Pragma_Exit.
4456 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
4457 -- Check the specified argument Arg to make sure that it has the proper
4458 -- syntactic form for a local name and meets the semantic requirements
4459 -- for a local name. The local name is analyzed as part of the
4460 -- processing for this call. In addition, the local name is required
4461 -- to represent an entity at the library level.
4463 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
4464 -- Check the specified argument Arg to make sure that it has the proper
4465 -- syntactic form for a local name and meets the semantic requirements
4466 -- for a local name. The local name is analyzed as part of the
4467 -- processing for this call.
4469 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
4470 -- Check the specified argument Arg to make sure that it is a valid
4471 -- locking policy name. If not give error and raise Pragma_Exit.
4473 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
4474 -- Check the specified argument Arg to make sure that it is a valid
4475 -- elaboration policy name. If not give error and raise Pragma_Exit.
4477 procedure Check_Arg_Is_One_Of
4480 procedure Check_Arg_Is_One_Of
4482 N1
, N2
, N3
: Name_Id
);
4483 procedure Check_Arg_Is_One_Of
4485 N1
, N2
, N3
, N4
: Name_Id
);
4486 procedure Check_Arg_Is_One_Of
4488 N1
, N2
, N3
, N4
, N5
: Name_Id
);
4489 -- Check the specified argument Arg to make sure that it is an
4490 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
4491 -- present). If not then give error and raise Pragma_Exit.
4493 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
4494 -- Check the specified argument Arg to make sure that it is a valid
4495 -- queuing policy name. If not give error and raise Pragma_Exit.
4497 procedure Check_Arg_Is_OK_Static_Expression
4499 Typ
: Entity_Id
:= Empty
);
4500 -- Check the specified argument Arg to make sure that it is a static
4501 -- expression of the given type (i.e. it will be analyzed and resolved
4502 -- using this type, which can be any valid argument to Resolve, e.g.
4503 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4504 -- Typ is left Empty, then any static expression is allowed. Includes
4505 -- checking that the argument does not raise Constraint_Error.
4507 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
4508 -- Check the specified argument Arg to make sure that it is a valid task
4509 -- dispatching policy name. If not give error and raise Pragma_Exit.
4511 procedure Check_Arg_Order
(Names
: Name_List
);
4512 -- Checks for an instance of two arguments with identifiers for the
4513 -- current pragma which are not in the sequence indicated by Names,
4514 -- and if so, generates a fatal message about bad order of arguments.
4516 procedure Check_At_Least_N_Arguments
(N
: Nat
);
4517 -- Check there are at least N arguments present
4519 procedure Check_At_Most_N_Arguments
(N
: Nat
);
4520 -- Check there are no more than N arguments present
4522 procedure Check_Component
4525 In_Variant_Part
: Boolean := False);
4526 -- Examine an Unchecked_Union component for correct use of per-object
4527 -- constrained subtypes, and for restrictions on finalizable components.
4528 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
4529 -- should be set when Comp comes from a record variant.
4531 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
4532 -- Check if a rep item of the same name as the current pragma is already
4533 -- chained as a rep pragma to the given entity. If so give a message
4534 -- about the duplicate, and then raise Pragma_Exit so does not return.
4535 -- Note that if E is a type, then this routine avoids flagging a pragma
4536 -- which applies to a parent type from which E is derived.
4538 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
4539 -- Nam is an N_String_Literal node containing the external name set by
4540 -- an Import or Export pragma (or extended Import or Export pragma).
4541 -- This procedure checks for possible duplications if this is the export
4542 -- case, and if found, issues an appropriate error message.
4544 procedure Check_Expr_Is_OK_Static_Expression
4546 Typ
: Entity_Id
:= Empty
);
4547 -- Check the specified expression Expr to make sure that it is a static
4548 -- expression of the given type (i.e. it will be analyzed and resolved
4549 -- using this type, which can be any valid argument to Resolve, e.g.
4550 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4551 -- Typ is left Empty, then any static expression is allowed. Includes
4552 -- checking that the expression does not raise Constraint_Error.
4554 procedure Check_First_Subtype
(Arg
: Node_Id
);
4555 -- Checks that Arg, whose expression is an entity name, references a
4558 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4559 -- Checks that the given argument has an identifier, and if so, requires
4560 -- it to match the given identifier name. If there is no identifier, or
4561 -- a non-matching identifier, then an error message is given and
4562 -- Pragma_Exit is raised.
4564 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
4565 -- Checks that the given argument has an identifier, and if so, requires
4566 -- it to match one of the given identifier names. If there is no
4567 -- identifier, or a non-matching identifier, then an error message is
4568 -- given and Pragma_Exit is raised.
4570 procedure Check_In_Main_Program
;
4571 -- Common checks for pragmas that appear within a main program
4572 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4574 procedure Check_Interrupt_Or_Attach_Handler
;
4575 -- Common processing for first argument of pragma Interrupt_Handler or
4576 -- pragma Attach_Handler.
4578 procedure Check_Loop_Pragma_Placement
;
4579 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4580 -- appear immediately within a construct restricted to loops, and that
4581 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4583 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
4584 -- Check that pragma appears in a declarative part, or in a package
4585 -- specification, i.e. that it does not occur in a statement sequence
4588 procedure Check_No_Identifier
(Arg
: Node_Id
);
4589 -- Checks that the given argument does not have an identifier. If
4590 -- an identifier is present, then an error message is issued, and
4591 -- Pragma_Exit is raised.
4593 procedure Check_No_Identifiers
;
4594 -- Checks that none of the arguments to the pragma has an identifier.
4595 -- If any argument has an identifier, then an error message is issued,
4596 -- and Pragma_Exit is raised.
4598 procedure Check_No_Link_Name
;
4599 -- Checks that no link name is specified
4601 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4602 -- Checks if the given argument has an identifier, and if so, requires
4603 -- it to match the given identifier name. If there is a non-matching
4604 -- identifier, then an error message is given and Pragma_Exit is raised.
4606 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
4607 -- Checks if the given argument has an identifier, and if so, requires
4608 -- it to match the given identifier name. If there is a non-matching
4609 -- identifier, then an error message is given and Pragma_Exit is raised.
4610 -- In this version of the procedure, the identifier name is given as
4611 -- a string with lower case letters.
4613 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
4614 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4615 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4616 -- Extensions_Visible, Side_Effects and Volatile_Function. Ensure
4617 -- that expression Expr is an OK static boolean expression. Emit an
4618 -- error if this is not the case.
4620 procedure Check_Static_Constraint
(Constr
: Node_Id
);
4621 -- Constr is a constraint from an N_Subtype_Indication node from a
4622 -- component constraint in an Unchecked_Union type, a range, or a
4623 -- discriminant association. This routine checks that the constraint
4624 -- is static as required by the restrictions for Unchecked_Union.
4626 procedure Check_Valid_Configuration_Pragma
;
4627 -- Legality checks for placement of a configuration pragma
4629 procedure Check_Valid_Library_Unit_Pragma
;
4630 -- Legality checks for library unit pragmas. A special case arises for
4631 -- pragmas in generic instances that come from copies of the original
4632 -- library unit pragmas in the generic templates. In the case of other
4633 -- than library level instantiations these can appear in contexts which
4634 -- would normally be invalid (they only apply to the original template
4635 -- and to library level instantiations), and they are simply ignored,
4636 -- which is implemented by rewriting them as null statements and
4637 -- optionally raising Pragma_Exit to terminate analysis. An exception
4638 -- is not always raised to avoid exception propagation during the
4639 -- bootstrap, so all callers should check whether N has been rewritten.
4641 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
4642 -- Check an Unchecked_Union variant for lack of nested variants and
4643 -- presence of at least one component. UU_Typ is the related Unchecked_
4646 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
4647 -- Subsidiary routine to the processing of pragmas Abstract_State,
4648 -- Contract_Cases, Depends, Exceptional_Cases, Global, Initializes,
4649 -- Refined_Depends, Refined_Global, Refined_State and
4650 -- Subprogram_Variant. Transform argument Arg into an aggregate if not
4651 -- one already. N_Null is never transformed. Arg may denote an aspect
4652 -- specification or a pragma argument association.
4654 procedure Error_Pragma
(Msg
: String);
4655 pragma No_Return
(Error_Pragma
);
4656 -- Outputs error message for current pragma. The message contains a %
4657 -- that will be replaced with the pragma name, and the flag is placed
4658 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4659 -- calls Fix_Error (see spec of that procedure for details).
4661 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
4662 pragma No_Return
(Error_Pragma_Arg
);
4663 -- Outputs error message for current pragma. The message may contain
4664 -- a % that will be replaced with the pragma name. The parameter Arg
4665 -- may either be a pragma argument association, in which case the flag
4666 -- is placed on the expression of this association, or an expression,
4667 -- in which case the flag is placed directly on the expression. The
4668 -- message is placed using Error_Msg_N, so the message may also contain
4669 -- an & insertion character which will reference the given Arg value.
4670 -- After placing the message, Pragma_Exit is raised. Note: this routine
4671 -- calls Fix_Error (see spec of that procedure for details).
4673 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
4674 pragma No_Return
(Error_Pragma_Arg
);
4675 -- Similar to above form of Error_Pragma_Arg except that two messages
4676 -- are provided, the second is a continuation comment starting with \.
4678 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
4679 pragma No_Return
(Error_Pragma_Arg_Ident
);
4680 -- Outputs error message for current pragma. The message may contain a %
4681 -- that will be replaced with the pragma name. The parameter Arg must be
4682 -- a pragma argument association with a non-empty identifier (i.e. its
4683 -- Chars field must be set), and the error message is placed on the
4684 -- identifier. The message is placed using Error_Msg_N so the message
4685 -- may also contain an & insertion character which will reference
4686 -- the identifier. After placing the message, Pragma_Exit is raised.
4687 -- Note: this routine calls Fix_Error (see spec of that procedure for
4690 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4691 pragma No_Return
(Error_Pragma_Ref
);
4692 -- Outputs error message for current pragma. The message may contain
4693 -- a % that will be replaced with the pragma name. The parameter Ref
4694 -- must be an entity whose name can be referenced by & and sloc by #.
4695 -- After placing the message, Pragma_Exit is raised. Note: this routine
4696 -- calls Fix_Error (see spec of that procedure for details).
4698 function Find_Lib_Unit_Name
return Entity_Id
;
4699 -- Used for a library unit pragma to find the entity to which the
4700 -- library unit pragma applies, returns the entity found.
4702 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4703 -- If the pragma is a compilation unit pragma, the id must denote the
4704 -- compilation unit in the same compilation, and the pragma must appear
4705 -- in the list of preceding or trailing pragmas. If it is a program
4706 -- unit pragma that is not a compilation unit pragma, then the
4707 -- identifier must be visible.
4709 function Find_Unique_Parameterless_Procedure
4711 Arg
: Node_Id
) return Entity_Id
;
4712 -- Used for a procedure pragma to find the unique parameterless
4713 -- procedure identified by Name, returns it if it exists, otherwise
4714 -- errors out and uses Arg as the pragma argument for the message.
4716 function Fix_Error
(Msg
: String) return String;
4717 -- This is called prior to issuing an error message. Msg is the normal
4718 -- error message issued in the pragma case. This routine checks for the
4719 -- case of a pragma coming from an aspect in the source, and returns a
4720 -- message suitable for the aspect case as follows:
4722 -- Each substring "pragma" is replaced by "aspect"
4724 -- If "argument of" is at the start of the error message text, it is
4725 -- replaced by "entity for".
4727 -- If "argument" is at the start of the error message text, it is
4728 -- replaced by "entity".
4730 -- So for example, "argument of pragma X must be discrete type"
4731 -- returns "entity for aspect X must be a discrete type".
4733 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4734 -- be different from the pragma name). If the current pragma results
4735 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4736 -- original pragma name.
4738 procedure Gather_Associations
4740 Args
: out Args_List
);
4741 -- This procedure is used to gather the arguments for a pragma that
4742 -- permits arbitrary ordering of parameters using the normal rules
4743 -- for named and positional parameters. The Names argument is a list
4744 -- of Name_Id values that corresponds to the allowed pragma argument
4745 -- association identifiers in order. The result returned in Args is
4746 -- a list of corresponding expressions that are the pragma arguments.
4747 -- Note that this is a list of expressions, not of pragma argument
4748 -- associations (Gather_Associations has completely checked all the
4749 -- optional identifiers when it returns). An entry in Args is Empty
4750 -- on return if the corresponding argument is not present.
4752 procedure GNAT_Pragma
;
4753 -- Called for all GNAT defined pragmas to check the relevant restriction
4754 -- (No_Implementation_Pragmas).
4756 function Is_Before_First_Decl
4757 (Pragma_Node
: Node_Id
;
4758 Decls
: List_Id
) return Boolean;
4759 -- Return True if Pragma_Node is before the first declarative item in
4760 -- Decls where Decls is the list of declarative items.
4762 function Is_Configuration_Pragma
return Boolean;
4763 -- Determines if the placement of the current pragma is appropriate
4764 -- for a configuration pragma.
4766 function Is_In_Context_Clause
return Boolean;
4767 -- Returns True if pragma appears within the context clause of a unit,
4768 -- and False for any other placement (does not generate any messages).
4770 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4771 -- Analyzes the argument, and determines if it is a static string
4772 -- expression, returns True if so, False if non-static or not String.
4773 -- A special case is that a string literal returns True in Ada 83 mode
4774 -- (which has no such thing as static string expressions). Note that
4775 -- the call analyzes its argument, so this cannot be used for the case
4776 -- where an identifier might not be declared.
4778 procedure Pragma_Misplaced
;
4779 pragma No_Return
(Pragma_Misplaced
);
4780 -- Issue fatal error message for misplaced pragma
4782 procedure Process_Atomic_Independent_Shared_Volatile
;
4783 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4784 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4785 -- and treated as being identical in effect to pragma Atomic.
4787 procedure Process_Compile_Time_Warning_Or_Error
;
4788 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4790 procedure Process_Convention
4791 (C
: out Convention_Id
;
4792 Ent
: out Entity_Id
);
4793 -- Common processing for Convention, Interface, Import and Export.
4794 -- Checks first two arguments of pragma, and sets the appropriate
4795 -- convention value in the specified entity or entities. On return
4796 -- C is the convention, Ent is the referenced entity.
4798 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4799 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4800 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4802 procedure Process_Extended_Import_Export_Object_Pragma
4803 (Arg_Internal
: Node_Id
;
4804 Arg_External
: Node_Id
;
4805 Arg_Size
: Node_Id
);
4806 -- Common processing for the pragmas Import/Export_Object. The three
4807 -- arguments correspond to the three named parameters of the pragmas. An
4808 -- argument is empty if the corresponding parameter is not present in
4811 procedure Process_Extended_Import_Export_Internal_Arg
4812 (Arg_Internal
: Node_Id
:= Empty
);
4813 -- Common processing for all extended Import and Export pragmas. The
4814 -- argument is the pragma parameter for the Internal argument. If
4815 -- Arg_Internal is empty or inappropriate, an error message is posted.
4816 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4817 -- set to identify the referenced entity.
4819 procedure Process_Extended_Import_Export_Subprogram_Pragma
4820 (Arg_Internal
: Node_Id
;
4821 Arg_External
: Node_Id
;
4822 Arg_Parameter_Types
: Node_Id
;
4823 Arg_Result_Type
: Node_Id
:= Empty
;
4824 Arg_Mechanism
: Node_Id
;
4825 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4826 -- Common processing for all extended Import and Export pragmas applying
4827 -- to subprograms. The caller omits any arguments that do not apply to
4828 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4829 -- only in the Import_Function and Export_Function cases). The argument
4830 -- names correspond to the allowed pragma association identifiers.
4832 procedure Process_Generic_List
;
4833 -- Common processing for Share_Generic and Inline_Generic
4835 procedure Process_Import_Or_Interface
;
4836 -- Common processing for Import or Interface
4838 procedure Process_Import_Predefined_Type
;
4839 -- Processing for completing a type with pragma Import. This is used
4840 -- to declare types that match predefined C types, especially for cases
4841 -- without corresponding Ada predefined type.
4843 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4844 -- Inline status of a subprogram, indicated as follows:
4845 -- Suppressed: inlining is suppressed for the subprogram
4846 -- Disabled: no inlining is requested for the subprogram
4847 -- Enabled: inlining is requested/required for the subprogram
4849 procedure Process_Inline
(Status
: Inline_Status
);
4850 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4851 -- indicates the inline status specified by the pragma.
4853 procedure Process_Interface_Name
4854 (Subprogram_Def
: Entity_Id
;
4858 -- Given the last two arguments of pragma Import, pragma Export, or
4859 -- pragma Interface_Name, performs validity checks and sets the
4860 -- Interface_Name field of the given subprogram entity to the
4861 -- appropriate external or link name, depending on the arguments given.
4862 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4863 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4864 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4865 -- nor Link_Arg is present, the interface name is set to the default
4866 -- from the subprogram name. In addition, the pragma itself is passed
4867 -- to analyze any expressions in the case the pragma came from an aspect
4870 procedure Process_Interrupt_Or_Attach_Handler
;
4871 -- Common processing for Interrupt and Attach_Handler pragmas
4873 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4874 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4875 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4876 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4877 -- is not set in the Restrictions case.
4879 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4880 -- Common processing for Suppress and Unsuppress. The boolean parameter
4881 -- Suppress_Case is True for the Suppress case, and False for the
4884 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4885 -- Subsidiary to the analysis of pragmas Independent[_Components].
4886 -- Record such a pragma N applied to entity E for future checks.
4888 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4889 -- This procedure sets the Is_Exported flag for the given entity,
4890 -- checking that the entity was not previously imported. Arg is
4891 -- the argument that specified the entity. A check is also made
4892 -- for exporting inappropriate entities.
4894 procedure Set_Extended_Import_Export_External_Name
4895 (Internal_Ent
: Entity_Id
;
4896 Arg_External
: Node_Id
);
4897 -- Common processing for all extended import export pragmas. The first
4898 -- argument, Internal_Ent, is the internal entity, which has already
4899 -- been checked for validity by the caller. Arg_External is from the
4900 -- Import or Export pragma, and may be null if no External parameter
4901 -- was present. If Arg_External is present and is a non-null string
4902 -- (a null string is treated as the default), then the Interface_Name
4903 -- field of Internal_Ent is set appropriately.
4905 procedure Set_Imported
(E
: Entity_Id
);
4906 -- This procedure sets the Is_Imported flag for the given entity,
4907 -- checking that it is not previously exported or imported.
4909 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4910 -- Mech is a parameter passing mechanism (see Import_Function syntax
4911 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4912 -- has the right form, and if not issues an error message. If the
4913 -- argument has the right form then the Mechanism field of Ent is
4914 -- set appropriately.
4916 procedure Set_Rational_Profile
;
4917 -- Activate the set of configuration pragmas and permissions that make
4918 -- up the Rational profile.
4920 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4921 -- Activate the set of configuration pragmas and restrictions that make
4922 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4923 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4924 -- pragma node, which is used for error messages on any constructs
4925 -- violating the profile.
4927 ---------------------
4928 -- Ada_2005_Pragma --
4929 ---------------------
4931 procedure Ada_2005_Pragma
is
4933 if Ada_Version
<= Ada_95
then
4934 Check_Restriction
(No_Implementation_Pragmas
, N
);
4936 end Ada_2005_Pragma
;
4938 ---------------------
4939 -- Ada_2012_Pragma --
4940 ---------------------
4942 procedure Ada_2012_Pragma
is
4944 if Ada_Version
<= Ada_2005
then
4945 Check_Restriction
(No_Implementation_Pragmas
, N
);
4947 end Ada_2012_Pragma
;
4949 ----------------------------
4950 -- Analyze_Depends_Global --
4951 ----------------------------
4953 procedure Analyze_Depends_Global
4954 (Spec_Id
: out Entity_Id
;
4955 Subp_Decl
: out Node_Id
;
4956 Legal
: out Boolean)
4959 -- Assume that the pragma is illegal
4966 Check_Arg_Count
(1);
4968 -- Ensure the proper placement of the pragma. Depends/Global must be
4969 -- associated with a subprogram declaration or a body that acts as a
4972 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4976 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4979 -- Generic subprogram
4981 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4984 -- Object declaration of a single concurrent type
4986 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4987 and then Is_Single_Concurrent_Object
4988 (Unique_Defining_Entity
(Subp_Decl
))
4994 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4997 -- Abstract subprogram declaration
4999 elsif Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
5002 -- Subprogram body acts as spec
5004 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
5005 and then No
(Corresponding_Spec
(Subp_Decl
))
5009 -- Subprogram body stub acts as spec
5011 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5012 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
5016 -- Subprogram declaration
5018 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
5020 -- Pragmas Global and Depends are forbidden on null procedures
5021 -- (SPARK RM 6.1.2(2)).
5023 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
5024 and then Null_Present
(Specification
(Subp_Decl
))
5026 Error_Msg_N
(Fix_Error
5027 ("pragma % cannot apply to null procedure"), N
);
5033 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
5040 -- If we get here, then the pragma is legal
5043 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
5045 -- When the related context is an entry, the entry must belong to a
5046 -- protected unit (SPARK RM 6.1.4(6)).
5048 if Is_Entry_Declaration
(Spec_Id
)
5049 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
5053 -- When the related context is an anonymous object created for a
5054 -- simple concurrent type, the type must be a task
5055 -- (SPARK RM 6.1.4(6)).
5057 elsif Is_Single_Concurrent_Object
(Spec_Id
)
5058 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
5063 -- A pragma that applies to a Ghost entity becomes Ghost for the
5064 -- purposes of legality checks and removal of ignored Ghost code.
5066 Mark_Ghost_Pragma
(N
, Spec_Id
);
5067 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5068 end Analyze_Depends_Global
;
5070 ------------------------
5071 -- Analyze_If_Present --
5072 ------------------------
5074 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
5076 Analyze_If_Present_Internal
(N
, Id
, Included
=> False);
5077 end Analyze_If_Present
;
5079 --------------------------------
5080 -- Analyze_Pre_Post_Condition --
5081 --------------------------------
5083 procedure Analyze_Pre_Post_Condition
is
5084 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
5085 Subp_Decl
: Node_Id
;
5086 Subp_Id
: Entity_Id
;
5088 Duplicates_OK
: Boolean := False;
5089 -- Flag set when a pre/postcondition allows multiple pragmas of the
5092 In_Body_OK
: Boolean := False;
5093 -- Flag set when a pre/postcondition is allowed to appear on a body
5094 -- even though the subprogram may have a spec.
5096 Is_Pre_Post
: Boolean := False;
5097 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
5100 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
5101 -- Implement rules in AI12-0131: an overriding operation can have
5102 -- a class-wide precondition only if one of its ancestors has an
5103 -- explicit class-wide precondition.
5105 -----------------------------
5106 -- Inherits_Class_Wide_Pre --
5107 -----------------------------
5109 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
5110 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
5113 Prev
: Entity_Id
:= Overridden_Operation
(E
);
5116 -- Check ancestors on the overriding operation to examine the
5117 -- preconditions that may apply to them.
5119 while Present
(Prev
) loop
5120 Cont
:= Contract
(Prev
);
5121 if Present
(Cont
) then
5122 Prag
:= Pre_Post_Conditions
(Cont
);
5123 while Present
(Prag
) loop
5124 if Pragma_Name
(Prag
) = Name_Precondition
5125 and then Class_Present
(Prag
)
5130 Prag
:= Next_Pragma
(Prag
);
5134 -- For a type derived from a generic formal type, the operation
5135 -- inheriting the condition is a renaming, not an overriding of
5136 -- the operation of the formal. Ditto for an inherited
5137 -- operation which has no explicit contracts.
5139 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
5140 or else not Comes_From_Source
(Prev
)
5142 Prev
:= Alias
(Prev
);
5144 Prev
:= Overridden_Operation
(Prev
);
5148 -- If the controlling type of the subprogram has progenitors, an
5149 -- interface operation implemented by the current operation may
5150 -- have a class-wide precondition.
5152 if Has_Interfaces
(Typ
) then
5157 Prim_Elmt
: Elmt_Id
;
5158 Prim_List
: Elist_Id
;
5161 Collect_Interfaces
(Typ
, Ints
);
5162 Elmt
:= First_Elmt
(Ints
);
5164 -- Iterate over the primitive operations of each interface
5166 while Present
(Elmt
) loop
5167 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
5168 Prim_Elmt
:= First_Elmt
(Prim_List
);
5169 while Present
(Prim_Elmt
) loop
5170 Prim
:= Node
(Prim_Elmt
);
5171 if Chars
(Prim
) = Chars
(E
)
5172 and then Present
(Contract
(Prim
))
5173 and then Class_Present
5174 (Pre_Post_Conditions
(Contract
(Prim
)))
5179 Next_Elmt
(Prim_Elmt
);
5188 end Inherits_Class_Wide_Pre
;
5190 -- Start of processing for Analyze_Pre_Post_Condition
5193 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
5194 -- offer uniformity among the various kinds of pre/postconditions by
5195 -- rewriting the pragma identifier. This allows the retrieval of the
5196 -- original pragma name by routine Original_Aspect_Pragma_Name.
5198 if Comes_From_Source
(N
) then
5199 if Pname
in Name_Pre | Name_Pre_Class
then
5200 Is_Pre_Post
:= True;
5201 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
5202 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
5204 elsif Pname
in Name_Post | Name_Post_Class
then
5205 Is_Pre_Post
:= True;
5206 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
5207 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
5211 -- Determine the semantics with respect to duplicates and placement
5212 -- in a body. Pragmas Precondition and Postcondition were introduced
5213 -- before aspects and are not subject to the same aspect-like rules.
5215 if Pname
in Name_Precondition | Name_Postcondition
then
5216 Duplicates_OK
:= True;
5222 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
5223 -- argument without an identifier.
5226 Check_Arg_Count
(1);
5227 Check_No_Identifiers
;
5229 -- Pragmas Precondition and Postcondition have complex argument
5233 Check_At_Least_N_Arguments
(1);
5234 Check_At_Most_N_Arguments
(2);
5235 Check_Optional_Identifier
(Arg1
, Name_Check
);
5237 if Present
(Arg2
) then
5238 Check_Optional_Identifier
(Arg2
, Name_Message
);
5239 Preanalyze_Spec_Expression
5240 (Get_Pragma_Arg
(Arg2
), Standard_String
);
5244 -- For a pragma PPC in the extended main source unit, record enabled
5246 -- ??? nothing checks that the pragma is in the main source unit
5248 if Is_Checked
(N
) and then not Split_PPC
(N
) then
5249 Set_SCO_Pragma_Enabled
(Loc
);
5252 -- Ensure the proper placement of the pragma
5255 Find_Related_Declaration_Or_Body
5256 (N
, Do_Checks
=> not Duplicates_OK
);
5258 -- When a pre/postcondition pragma applies to an abstract subprogram,
5259 -- its original form must be an aspect with 'Class.
5261 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
5262 if not From_Aspect_Specification
(N
) then
5264 ("pragma % cannot be applied to abstract subprogram");
5266 elsif not Class_Present
(N
) then
5268 ("aspect % requires ''Class for abstract subprogram");
5271 -- Entry declaration
5273 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
5276 -- Generic subprogram declaration
5278 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
5283 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
5284 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
5288 -- Subprogram body stub
5290 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5291 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
5295 -- Subprogram declaration
5297 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
5299 -- AI05-0230: When a pre/postcondition pragma applies to a null
5300 -- procedure, its original form must be an aspect with 'Class.
5302 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
5303 and then Null_Present
(Specification
(Subp_Decl
))
5304 and then From_Aspect_Specification
(N
)
5305 and then not Class_Present
(N
)
5307 Error_Pragma
("aspect % requires ''Class for null procedure");
5310 -- Implement the legality checks mandated by AI12-0131:
5311 -- Pre'Class shall not be specified for an overriding primitive
5312 -- subprogram of a tagged type T unless the Pre'Class aspect is
5313 -- specified for the corresponding primitive subprogram of some
5317 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
5320 if Class_Present
(N
)
5321 and then Pragma_Name
(N
) = Name_Precondition
5322 and then Present
(Overridden_Operation
(E
))
5323 and then not Inherits_Class_Wide_Pre
(E
)
5326 ("illegal class-wide precondition on overriding operation",
5327 Corresponding_Aspect
(N
));
5331 -- A renaming declaration may inherit a generated pragma, its
5332 -- placement comes from expansion, not from source.
5334 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
5335 and then not Comes_From_Source
(N
)
5339 -- For Ada 2022, pre/postconditions can appear on formal subprograms
5341 elsif Nkind
(Subp_Decl
) = N_Formal_Concrete_Subprogram_Declaration
5342 and then Ada_Version
>= Ada_2022
5346 -- An access-to-subprogram type can have pre/postconditions, which
5347 -- are both analyzed when attached to the type and copied to the
5348 -- generated subprogram wrapper and analyzed there.
5350 elsif Nkind
(Subp_Decl
) = N_Full_Type_Declaration
5351 and then Nkind
(Type_Definition
(Subp_Decl
)) in
5352 N_Access_To_Subprogram_Definition
5354 if Ada_Version
< Ada_2022
then
5355 Error_Msg_Ada_2022_Feature
5356 ("pre/postcondition on access-to-subprogram", Loc
);
5360 -- Otherwise the placement of the pragma is illegal
5366 Subp_Id
:= Defining_Entity
(Subp_Decl
);
5368 -- A pragma that applies to a Ghost entity becomes Ghost for the
5369 -- purposes of legality checks and removal of ignored Ghost code.
5371 Mark_Ghost_Pragma
(N
, Subp_Id
);
5373 -- Chain the pragma on the contract for further processing by
5374 -- Analyze_Pre_Post_Condition_In_Decl_Part.
5376 if Ekind
(Subp_Id
) in Access_Subprogram_Kind
then
5377 Add_Contract_Item
(N
, Directly_Designated_Type
(Subp_Id
));
5379 Add_Contract_Item
(N
, Subp_Id
);
5382 -- Fully analyze the pragma when it appears inside an entry or
5383 -- subprogram body because it cannot benefit from forward references.
5385 if Nkind
(Subp_Decl
) in N_Entry_Body
5387 | N_Subprogram_Body_Stub
5389 -- The legality checks of pragmas Precondition and Postcondition
5390 -- are affected by the SPARK mode in effect and the volatility of
5391 -- the context. Analyze all pragmas in a specific order.
5393 Analyze_If_Present
(Pragma_SPARK_Mode
);
5394 Analyze_If_Present
(Pragma_Volatile_Function
);
5395 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
5397 end Analyze_Pre_Post_Condition
;
5399 -----------------------------------------
5400 -- Analyze_Refined_Depends_Global_Post --
5401 -----------------------------------------
5403 procedure Analyze_Refined_Depends_Global_Post
5404 (Spec_Id
: out Entity_Id
;
5405 Body_Id
: out Entity_Id
;
5406 Legal
: out Boolean)
5408 Body_Decl
: Node_Id
;
5409 Spec_Decl
: Node_Id
;
5412 -- Assume that the pragma is illegal
5419 Check_Arg_Count
(1);
5420 Check_No_Identifiers
;
5422 -- Verify the placement of the pragma and check for duplicates. The
5423 -- pragma must apply to a subprogram body [stub].
5425 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
5427 if Nkind
(Body_Decl
) not in
5428 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
5429 N_Task_Body | N_Task_Body_Stub
5434 Body_Id
:= Defining_Entity
(Body_Decl
);
5435 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
5437 -- The pragma must apply to the second declaration of a subprogram.
5438 -- In other words, the body [stub] cannot acts as a spec.
5440 if No
(Spec_Id
) then
5441 Error_Pragma
("pragma % cannot apply to a stand alone body");
5443 -- Catch the case where the subprogram body is a subunit and acts as
5444 -- the third declaration of the subprogram.
5446 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5447 Error_Pragma
("pragma % cannot apply to a subunit");
5450 -- A refined pragma can only apply to the body [stub] of a subprogram
5451 -- declared in the visible part of a package. Retrieve the context of
5452 -- the subprogram declaration.
5454 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
5456 -- When dealing with protected entries or protected subprograms, use
5457 -- the enclosing protected type as the proper context.
5459 if Ekind
(Spec_Id
) in E_Entry
5463 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
5465 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
5468 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
5470 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
5471 & "subprogram declared in a package specification"));
5474 -- If we get here, then the pragma is legal
5478 -- A pragma that applies to a Ghost entity becomes Ghost for the
5479 -- purposes of legality checks and removal of ignored Ghost code.
5481 Mark_Ghost_Pragma
(N
, Spec_Id
);
5483 if Pname
in Name_Refined_Depends | Name_Refined_Global
then
5484 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5486 end Analyze_Refined_Depends_Global_Post
;
5488 ----------------------------------
5489 -- Analyze_Unmodified_Or_Unused --
5490 ----------------------------------
5492 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
5497 Ghost_Error_Posted
: Boolean := False;
5498 -- Flag set when an error concerning the illegal mix of Ghost and
5499 -- non-Ghost variables is emitted.
5501 Ghost_Id
: Entity_Id
:= Empty
;
5502 -- The entity of the first Ghost variable encountered while
5503 -- processing the arguments of the pragma.
5507 Check_At_Least_N_Arguments
(1);
5509 -- Loop through arguments
5512 while Present
(Arg
) loop
5513 Check_No_Identifier
(Arg
);
5515 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5516 -- in fact generate reference, so that the entity will have a
5517 -- reference, which will inhibit any warnings about it not
5518 -- being referenced, and also properly show up in the ali file
5519 -- as a reference. But this reference is recorded before the
5520 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5521 -- generated for this reference.
5523 Check_Arg_Is_Local_Name
(Arg
);
5524 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5526 if Is_Entity_Name
(Arg_Expr
) then
5527 Arg_Id
:= Entity
(Arg_Expr
);
5529 -- Skip processing the argument if already flagged
5531 if Is_Assignable
(Arg_Id
)
5532 and then not Has_Pragma_Unmodified
(Arg_Id
)
5533 and then not Has_Pragma_Unused
(Arg_Id
)
5535 Set_Has_Pragma_Unmodified
(Arg_Id
);
5538 Set_Has_Pragma_Unused
(Arg_Id
);
5541 -- A pragma that applies to a Ghost entity becomes Ghost for
5542 -- the purposes of legality checks and removal of ignored
5545 Mark_Ghost_Pragma
(N
, Arg_Id
);
5547 -- Capture the entity of the first Ghost variable being
5548 -- processed for error detection purposes.
5550 if Is_Ghost_Entity
(Arg_Id
) then
5551 if No
(Ghost_Id
) then
5555 -- Otherwise the variable is non-Ghost. It is illegal to mix
5556 -- references to Ghost and non-Ghost entities
5559 elsif Present
(Ghost_Id
)
5560 and then not Ghost_Error_Posted
5562 Ghost_Error_Posted
:= True;
5564 Error_Msg_Name_1
:= Pname
;
5566 ("pragma % cannot mention ghost and non-ghost "
5569 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5570 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
5572 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5573 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
5576 -- Warn if already flagged as Unused or Unmodified
5578 elsif Has_Pragma_Unmodified
(Arg_Id
) then
5579 if Has_Pragma_Unused
(Arg_Id
) then
5581 (Fix_Error
("??pragma Unused already given for &!"),
5585 (Fix_Error
("??pragma Unmodified already given for &!"),
5589 -- Otherwise the pragma referenced an illegal entity
5593 ("pragma% can only be applied to a variable", Arg_Expr
);
5599 end Analyze_Unmodified_Or_Unused
;
5601 ------------------------------------
5602 -- Analyze_Unreferenced_Or_Unused --
5603 ------------------------------------
5605 procedure Analyze_Unreferenced_Or_Unused
5606 (Is_Unused
: Boolean := False)
5613 Ghost_Error_Posted
: Boolean := False;
5614 -- Flag set when an error concerning the illegal mix of Ghost and
5615 -- non-Ghost names is emitted.
5617 Ghost_Id
: Entity_Id
:= Empty
;
5618 -- The entity of the first Ghost name encountered while processing
5619 -- the arguments of the pragma.
5623 Check_At_Least_N_Arguments
(1);
5625 -- Check case of appearing within context clause
5627 if not Is_Unused
and then Is_In_Context_Clause
then
5629 -- The arguments must all be units mentioned in a with clause in
5630 -- the same context clause. Note that Par.Prag already checked
5631 -- that the arguments are either identifiers or selected
5635 while Present
(Arg
) loop
5636 Citem
:= First
(List_Containing
(N
));
5637 while Citem
/= N
loop
5638 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5640 if Nkind
(Citem
) = N_With_Clause
5641 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5643 Set_Has_Pragma_Unreferenced
5646 (Library_Unit
(Citem
))));
5647 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5656 ("argument of pragma% is not withed unit", Arg
);
5662 -- Case of not in list of context items
5666 while Present
(Arg
) loop
5667 Check_No_Identifier
(Arg
);
5669 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5670 -- in fact generate reference, so that the entity will have a
5671 -- reference, which will inhibit any warnings about it not
5672 -- being referenced, and also properly show up in the ali file
5673 -- as a reference. But this reference is recorded before the
5674 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5675 -- generated for this reference.
5677 Check_Arg_Is_Local_Name
(Arg
);
5678 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5680 if Is_Entity_Name
(Arg_Expr
) then
5681 Arg_Id
:= Entity
(Arg_Expr
);
5683 -- Warn if already flagged as Unused or Unreferenced and
5684 -- skip processing the argument.
5686 if Has_Pragma_Unreferenced
(Arg_Id
) then
5687 if Has_Pragma_Unused
(Arg_Id
) then
5689 (Fix_Error
("??pragma Unused already given for &!"),
5694 ("??pragma Unreferenced already given for &!"),
5698 -- Apply Unreferenced to the entity
5701 -- If the entity is overloaded, the pragma applies to the
5702 -- most recent overloading, as documented. In this case,
5703 -- name resolution does not generate a reference, so it
5704 -- must be done here explicitly.
5706 if Is_Overloaded
(Arg_Expr
) then
5707 Generate_Reference
(Arg_Id
, N
);
5710 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5713 Set_Has_Pragma_Unused
(Arg_Id
);
5716 -- A pragma that applies to a Ghost entity becomes Ghost
5717 -- for the purposes of legality checks and removal of
5718 -- ignored Ghost code.
5720 Mark_Ghost_Pragma
(N
, Arg_Id
);
5722 -- Capture the entity of the first Ghost name being
5723 -- processed for error detection purposes.
5725 if Is_Ghost_Entity
(Arg_Id
) then
5726 if No
(Ghost_Id
) then
5730 -- Otherwise the name is non-Ghost. It is illegal to mix
5731 -- references to Ghost and non-Ghost entities
5734 elsif Present
(Ghost_Id
)
5735 and then not Ghost_Error_Posted
5737 Ghost_Error_Posted
:= True;
5739 Error_Msg_Name_1
:= Pname
;
5741 ("pragma % cannot mention ghost and non-ghost "
5744 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5746 ("\& # declared as ghost", N
, Ghost_Id
);
5748 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5750 ("\& # declared as non-ghost", N
, Arg_Id
);
5758 end Analyze_Unreferenced_Or_Unused
;
5760 --------------------------
5761 -- Check_Ada_83_Warning --
5762 --------------------------
5764 procedure Check_Ada_83_Warning
is
5766 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5767 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5769 end Check_Ada_83_Warning
;
5771 ---------------------
5772 -- Check_Arg_Count --
5773 ---------------------
5775 procedure Check_Arg_Count
(Required
: Nat
) is
5777 if Arg_Count
/= Required
then
5778 Error_Pragma
("wrong number of arguments for pragma%");
5780 end Check_Arg_Count
;
5782 --------------------------------
5783 -- Check_Arg_Is_External_Name --
5784 --------------------------------
5786 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5787 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5790 if Nkind
(Argx
) = N_Identifier
then
5794 Analyze_And_Resolve
(Argx
, Standard_String
);
5796 if Is_OK_Static_Expression
(Argx
) then
5799 elsif Etype
(Argx
) = Any_Type
then
5802 -- An interesting special case, if we have a string literal and
5803 -- we are in Ada 83 mode, then we allow it even though it will
5804 -- not be flagged as static. This allows expected Ada 83 mode
5805 -- use of external names which are string literals, even though
5806 -- technically these are not static in Ada 83.
5808 elsif Ada_Version
= Ada_83
5809 and then Nkind
(Argx
) = N_String_Literal
5813 -- Here we have a real error (non-static expression)
5816 Error_Msg_Name_1
:= Pname
;
5817 Flag_Non_Static_Expr
5818 (Fix_Error
("argument for pragma% must be a identifier or "
5819 & "static string expression!"), Argx
);
5824 end Check_Arg_Is_External_Name
;
5826 -----------------------------
5827 -- Check_Arg_Is_Identifier --
5828 -----------------------------
5830 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5831 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5833 if Nkind
(Argx
) /= N_Identifier
then
5834 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5836 end Check_Arg_Is_Identifier
;
5838 ----------------------------------
5839 -- Check_Arg_Is_Integer_Literal --
5840 ----------------------------------
5842 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5843 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5845 if Nkind
(Argx
) /= N_Integer_Literal
then
5847 ("argument for pragma% must be integer literal", Argx
);
5849 end Check_Arg_Is_Integer_Literal
;
5851 -------------------------------------------
5852 -- Check_Arg_Is_Library_Level_Local_Name --
5853 -------------------------------------------
5857 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5858 -- | library_unit_NAME
5860 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5862 Check_Arg_Is_Local_Name
(Arg
);
5864 -- If it came from an aspect, we want to give the error just as if it
5865 -- came from source.
5867 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5868 and then (Comes_From_Source
(N
)
5869 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5872 ("argument for pragma% must be library level entity", Arg
);
5874 end Check_Arg_Is_Library_Level_Local_Name
;
5876 -----------------------------
5877 -- Check_Arg_Is_Local_Name --
5878 -----------------------------
5882 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5883 -- | library_unit_NAME
5885 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5886 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5889 -- If this pragma came from an aspect specification, we don't want to
5890 -- check for this error, because that would cause spurious errors, in
5891 -- case a type is frozen in a scope more nested than the type. The
5892 -- aspect itself of course can't be anywhere but on the declaration
5895 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5896 if From_Aspect_Specification
(Parent
(Arg
)) then
5900 -- Arg is the Expression of an N_Pragma_Argument_Association
5903 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5910 if Nkind
(Argx
) not in N_Direct_Name
5911 and then (Nkind
(Argx
) /= N_Attribute_Reference
5912 or else Present
(Expressions
(Argx
))
5913 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5914 and then (not Is_Entity_Name
(Argx
)
5915 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5917 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5920 -- No further check required if not an entity name
5922 if not Is_Entity_Name
(Argx
) then
5928 Ent
: constant Entity_Id
:= Entity
(Argx
);
5929 Scop
: constant Entity_Id
:= Scope
(Ent
);
5932 -- Case of a pragma applied to a compilation unit: pragma must
5933 -- occur immediately after the program unit in the compilation.
5935 if Is_Compilation_Unit
(Ent
) then
5937 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5940 -- Case of pragma placed immediately after spec
5942 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5945 -- Case of pragma placed immediately after body
5947 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5948 and then Present
(Corresponding_Body
(Decl
))
5952 (Parent
(Unit_Declaration_Node
5953 (Corresponding_Body
(Decl
))));
5955 -- All other cases are illegal
5962 -- Special restricted placement rule from 10.2.1(11.8/2)
5964 elsif Is_Generic_Formal
(Ent
)
5965 and then Prag_Id
= Pragma_Preelaborable_Initialization
5967 OK
:= List_Containing
(N
) =
5968 Generic_Formal_Declarations
5969 (Unit_Declaration_Node
(Scop
));
5971 -- If this is an aspect applied to a subprogram body, the
5972 -- pragma is inserted in its declarative part.
5974 elsif From_Aspect_Specification
(N
)
5975 and then Ent
= Current_Scope
5977 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5981 -- If the aspect is a predicate (possibly others ???) and the
5982 -- context is a record type, this is a discriminant expression
5983 -- within a type declaration, that freezes the predicated
5986 elsif From_Aspect_Specification
(N
)
5987 and then Prag_Id
= Pragma_Predicate
5988 and then Ekind
(Current_Scope
) = E_Record_Type
5989 and then Scop
= Scope
(Current_Scope
)
5993 -- Special case for postconditions wrappers
5995 elsif Ekind
(Scop
) in Subprogram_Kind
5996 and then Present
(Wrapped_Statements
(Scop
))
5997 and then Wrapped_Statements
(Scop
) = Current_Scope
6001 -- Default case, just check that the pragma occurs in the scope
6002 -- of the entity denoted by the name.
6005 OK
:= Current_Scope
= Scop
;
6010 ("pragma% argument must be in same declarative part", Arg
);
6014 end Check_Arg_Is_Local_Name
;
6016 ---------------------------------
6017 -- Check_Arg_Is_Locking_Policy --
6018 ---------------------------------
6020 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
6021 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6024 Check_Arg_Is_Identifier
(Argx
);
6026 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
6027 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
6029 end Check_Arg_Is_Locking_Policy
;
6031 -----------------------------------------------
6032 -- Check_Arg_Is_Partition_Elaboration_Policy --
6033 -----------------------------------------------
6035 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
6036 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6039 Check_Arg_Is_Identifier
(Argx
);
6041 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
6043 ("& is not a valid partition elaboration policy name", Argx
);
6045 end Check_Arg_Is_Partition_Elaboration_Policy
;
6047 -------------------------
6048 -- Check_Arg_Is_One_Of --
6049 -------------------------
6051 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
6052 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6055 Check_Arg_Is_Identifier
(Argx
);
6057 if Chars
(Argx
) not in N1 | N2
then
6058 Error_Msg_Name_2
:= N1
;
6059 Error_Msg_Name_3
:= N2
;
6060 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
6062 end Check_Arg_Is_One_Of
;
6064 procedure Check_Arg_Is_One_Of
6066 N1
, N2
, N3
: Name_Id
)
6068 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6071 Check_Arg_Is_Identifier
(Argx
);
6073 if Chars
(Argx
) not in N1 | N2 | N3
then
6074 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6076 end Check_Arg_Is_One_Of
;
6078 procedure Check_Arg_Is_One_Of
6080 N1
, N2
, N3
, N4
: Name_Id
)
6082 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6085 Check_Arg_Is_Identifier
(Argx
);
6087 if Chars
(Argx
) not in N1 | N2 | N3 | N4
then
6088 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6090 end Check_Arg_Is_One_Of
;
6092 procedure Check_Arg_Is_One_Of
6094 N1
, N2
, N3
, N4
, N5
: Name_Id
)
6096 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6099 Check_Arg_Is_Identifier
(Argx
);
6101 if Chars
(Argx
) not in N1 | N2 | N3 | N4 | N5
then
6102 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
6104 end Check_Arg_Is_One_Of
;
6106 ---------------------------------
6107 -- Check_Arg_Is_Queuing_Policy --
6108 ---------------------------------
6110 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
6111 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6114 Check_Arg_Is_Identifier
(Argx
);
6116 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
6117 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
6119 end Check_Arg_Is_Queuing_Policy
;
6121 ---------------------------------------
6122 -- Check_Arg_Is_OK_Static_Expression --
6123 ---------------------------------------
6125 procedure Check_Arg_Is_OK_Static_Expression
6127 Typ
: Entity_Id
:= Empty
)
6130 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
6131 end Check_Arg_Is_OK_Static_Expression
;
6133 ------------------------------------------
6134 -- Check_Arg_Is_Task_Dispatching_Policy --
6135 ------------------------------------------
6137 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
6138 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6141 Check_Arg_Is_Identifier
(Argx
);
6143 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
6145 ("& is not an allowed task dispatching policy name", Argx
);
6147 end Check_Arg_Is_Task_Dispatching_Policy
;
6149 ---------------------
6150 -- Check_Arg_Order --
6151 ---------------------
6153 procedure Check_Arg_Order
(Names
: Name_List
) is
6156 Highest_So_Far
: Natural := 0;
6157 -- Highest index in Names seen do far
6161 for J
in 1 .. Arg_Count
loop
6162 if Chars
(Arg
) /= No_Name
then
6163 for K
in Names
'Range loop
6164 if Chars
(Arg
) = Names
(K
) then
6165 if K
< Highest_So_Far
then
6166 Error_Msg_Name_1
:= Pname
;
6168 ("parameters out of order for pragma%", Arg
);
6169 Error_Msg_Name_1
:= Names
(K
);
6170 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
6171 Error_Msg_N
("\% must appear before %", Arg
);
6175 Highest_So_Far
:= K
;
6183 end Check_Arg_Order
;
6185 --------------------------------
6186 -- Check_At_Least_N_Arguments --
6187 --------------------------------
6189 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
6191 if Arg_Count
< N
then
6192 Error_Pragma
("too few arguments for pragma%");
6194 end Check_At_Least_N_Arguments
;
6196 -------------------------------
6197 -- Check_At_Most_N_Arguments --
6198 -------------------------------
6200 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
6203 if Arg_Count
> N
then
6205 for J
in 1 .. N
loop
6207 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
6210 end Check_At_Most_N_Arguments
;
6212 ---------------------
6213 -- Check_Component --
6214 ---------------------
6216 procedure Check_Component
6219 In_Variant_Part
: Boolean := False)
6221 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
6222 Sindic
: constant Node_Id
:=
6223 Subtype_Indication
(Component_Definition
(Comp
));
6224 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
6227 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
6228 -- object constraint, then the component type shall be an Unchecked_
6231 if Nkind
(Sindic
) = N_Subtype_Indication
6232 and then Has_Per_Object_Constraint
(Comp_Id
)
6233 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
6236 ("component subtype subject to per-object constraint "
6237 & "must be an Unchecked_Union", Comp
);
6239 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
6240 -- the body of a generic unit, or within the body of any of its
6241 -- descendant library units, no part of the type of a component
6242 -- declared in a variant_part of the unchecked union type shall be of
6243 -- a formal private type or formal private extension declared within
6244 -- the formal part of the generic unit.
6246 elsif Ada_Version
>= Ada_2012
6247 and then In_Generic_Body
(UU_Typ
)
6248 and then In_Variant_Part
6249 and then Is_Private_Type
(Typ
)
6250 and then Is_Generic_Type
(Typ
)
6253 ("component of unchecked union cannot be of generic type", Comp
);
6255 elsif Needs_Finalization
(Typ
) then
6257 ("component of unchecked union cannot be controlled", Comp
);
6259 elsif Has_Task
(Typ
) then
6261 ("component of unchecked union cannot have tasks", Comp
);
6263 end Check_Component
;
6265 ----------------------------
6266 -- Check_Duplicate_Pragma --
6267 ----------------------------
6269 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
6270 Id
: Entity_Id
:= E
;
6274 -- Nothing to do if this pragma comes from an aspect specification,
6275 -- since we could not be duplicating a pragma, and we dealt with the
6276 -- case of duplicated aspects in Analyze_Aspect_Specifications.
6278 if From_Aspect_Specification
(N
) then
6282 -- Otherwise current pragma may duplicate previous pragma or a
6283 -- previously given aspect specification or attribute definition
6284 -- clause for the same pragma.
6286 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
6290 -- If the entity is a type, then we have to make sure that the
6291 -- ostensible duplicate is not for a parent type from which this
6295 if Nkind
(P
) = N_Pragma
then
6297 Args
: constant List_Id
:=
6298 Pragma_Argument_Associations
(P
);
6301 and then Is_Entity_Name
(Expression
(First
(Args
)))
6302 and then Is_Type
(Entity
(Expression
(First
(Args
))))
6303 and then Entity
(Expression
(First
(Args
))) /= E
6309 elsif Nkind
(P
) = N_Aspect_Specification
6310 and then Is_Type
(Entity
(P
))
6311 and then Entity
(P
) /= E
6317 -- Here we have a definite duplicate
6319 Error_Msg_Name_1
:= Pragma_Name
(N
);
6320 Error_Msg_Sloc
:= Sloc
(P
);
6322 -- For a single protected or a single task object, the error is
6323 -- issued on the original entity.
6325 if Ekind
(Id
) in E_Task_Type | E_Protected_Type
then
6326 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
6329 if Nkind
(P
) = N_Aspect_Specification
6330 or else From_Aspect_Specification
(P
)
6332 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
6334 -- If -gnatwr is set, warn in case of a duplicate pragma
6335 -- [No_]Inline which is suspicious but not an error, generate
6336 -- an error for other pragmas.
6338 if Pragma_Name
(N
) in Name_Inline | Name_No_Inline
then
6339 if Warn_On_Redundant_Constructs
then
6341 ("?r?pragma% for & duplicates pragma#", N
, Id
);
6344 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
6350 end Check_Duplicate_Pragma
;
6352 ----------------------------------
6353 -- Check_Duplicated_Export_Name --
6354 ----------------------------------
6356 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
6357 String_Val
: constant String_Id
:= Strval
(Nam
);
6360 -- We are only interested in the export case, and in the case of
6361 -- generics, it is the instance, not the template, that is the
6362 -- problem (the template will generate a warning in any case).
6364 if not Inside_A_Generic
6365 and then (Prag_Id
= Pragma_Export
6367 Prag_Id
= Pragma_Export_Procedure
6369 Prag_Id
= Pragma_Export_Valued_Procedure
6371 Prag_Id
= Pragma_Export_Function
)
6373 for J
in Externals
.First
.. Externals
.Last
loop
6374 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
6375 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
6376 Error_Msg_N
("external name duplicates name given#", Nam
);
6381 Externals
.Append
(Nam
);
6383 end Check_Duplicated_Export_Name
;
6385 ----------------------------------------
6386 -- Check_Expr_Is_OK_Static_Expression --
6387 ----------------------------------------
6389 procedure Check_Expr_Is_OK_Static_Expression
6391 Typ
: Entity_Id
:= Empty
)
6394 if Present
(Typ
) then
6395 Analyze_And_Resolve
(Expr
, Typ
);
6397 Analyze_And_Resolve
(Expr
);
6400 -- An expression cannot be considered static if its resolution failed
6401 -- or if it's erroneous. Stop the analysis of the related pragma.
6403 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
6406 elsif Is_OK_Static_Expression
(Expr
) then
6409 -- An interesting special case, if we have a string literal and we
6410 -- are in Ada 83 mode, then we allow it even though it will not be
6411 -- flagged as static. This allows the use of Ada 95 pragmas like
6412 -- Import in Ada 83 mode. They will of course be flagged with
6413 -- warnings as usual, but will not cause errors.
6415 elsif Ada_Version
= Ada_83
6416 and then Nkind
(Expr
) = N_String_Literal
6420 -- Finally, we have a real error
6423 Error_Msg_Name_1
:= Pname
;
6424 Flag_Non_Static_Expr
6425 (Fix_Error
("argument for pragma% must be a static expression!"),
6429 end Check_Expr_Is_OK_Static_Expression
;
6431 -------------------------
6432 -- Check_First_Subtype --
6433 -------------------------
6435 procedure Check_First_Subtype
(Arg
: Node_Id
) is
6436 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6437 Ent
: constant Entity_Id
:= Entity
(Argx
);
6440 if Is_First_Subtype
(Ent
) then
6443 elsif Is_Type
(Ent
) then
6445 ("pragma% cannot apply to subtype", Argx
);
6447 elsif Is_Object
(Ent
) then
6449 ("pragma% cannot apply to object, requires a type", Argx
);
6453 ("pragma% cannot apply to&, requires a type", Argx
);
6455 end Check_First_Subtype
;
6457 ----------------------
6458 -- Check_Identifier --
6459 ----------------------
6461 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6464 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6466 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
6467 Error_Msg_Name_1
:= Pname
;
6468 Error_Msg_Name_2
:= Id
;
6469 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6473 end Check_Identifier
;
6475 --------------------------------
6476 -- Check_Identifier_Is_One_Of --
6477 --------------------------------
6479 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
6482 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6484 if Chars
(Arg
) = No_Name
then
6485 Error_Msg_Name_1
:= Pname
;
6486 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
6489 elsif Chars
(Arg
) /= N1
6490 and then Chars
(Arg
) /= N2
6492 Error_Msg_Name_1
:= Pname
;
6493 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
6497 end Check_Identifier_Is_One_Of
;
6499 ---------------------------
6500 -- Check_In_Main_Program --
6501 ---------------------------
6503 procedure Check_In_Main_Program
is
6504 P
: constant Node_Id
:= Parent
(N
);
6507 -- Must be in subprogram body
6509 if Nkind
(P
) /= N_Subprogram_Body
then
6510 Error_Pragma
("% pragma allowed only in subprogram");
6512 -- Otherwise warn if obviously not main program
6514 elsif Present
(Parameter_Specifications
(Specification
(P
)))
6515 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
6517 Error_Msg_Name_1
:= Pname
;
6519 ("??pragma% is only effective in main program", N
);
6521 end Check_In_Main_Program
;
6523 ---------------------------------------
6524 -- Check_Interrupt_Or_Attach_Handler --
6525 ---------------------------------------
6527 procedure Check_Interrupt_Or_Attach_Handler
is
6528 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6529 Handler_Proc
, Proc_Scope
: Entity_Id
;
6534 if Prag_Id
= Pragma_Interrupt_Handler
then
6535 Check_Restriction
(No_Dynamic_Attachment
, N
);
6538 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
6539 Proc_Scope
:= Scope
(Handler_Proc
);
6541 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
6543 ("argument of pragma% must be protected procedure", Arg1
);
6546 -- For pragma case (as opposed to access case), check placement.
6547 -- We don't need to do that for aspects, because we have the
6548 -- check that they aspect applies an appropriate procedure.
6550 if not From_Aspect_Specification
(N
)
6551 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
6553 Error_Pragma
("pragma% must be in protected definition");
6556 if not Is_Library_Level_Entity
(Proc_Scope
) then
6558 ("argument for pragma% must be library level entity", Arg1
);
6561 -- AI05-0033: A pragma cannot appear within a generic body, because
6562 -- instance can be in a nested scope. The check that protected type
6563 -- is itself a library-level declaration is done elsewhere.
6565 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6566 -- handle code prior to AI-0033. Analysis tools typically are not
6567 -- interested in this pragma in any case, so no need to worry too
6568 -- much about its placement.
6570 if Inside_A_Generic
then
6571 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
6572 and then In_Package_Body
(Scope
(Current_Scope
))
6573 and then not Relaxed_RM_Semantics
6575 Error_Pragma
("pragma% cannot be used inside a generic");
6578 end Check_Interrupt_Or_Attach_Handler
;
6580 ---------------------------------
6581 -- Check_Loop_Pragma_Placement --
6582 ---------------------------------
6584 procedure Check_Loop_Pragma_Placement
is
6585 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
6586 -- Verify whether the current pragma is properly grouped with other
6587 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6588 -- related loop where the pragma appears.
6590 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
6591 -- Determine whether an arbitrary statement Stmt denotes pragma
6592 -- Loop_Invariant or Loop_Variant.
6594 procedure Placement_Error
(Constr
: Node_Id
);
6595 pragma No_Return
(Placement_Error
);
6596 -- Node Constr denotes the last loop restricted construct before we
6597 -- encountered an illegal relation between enclosing constructs. Emit
6598 -- an error depending on what Constr was.
6600 --------------------------------
6601 -- Check_Loop_Pragma_Grouping --
6602 --------------------------------
6604 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6605 function Check_Grouping
(L
: List_Id
) return Boolean;
6606 -- Find the first group of pragmas in list L and if successful,
6607 -- ensure that the current pragma is part of that group. The
6608 -- routine returns True once such a check is performed to
6609 -- stop the analysis.
6611 procedure Grouping_Error
(Prag
: Node_Id
);
6612 pragma No_Return
(Grouping_Error
);
6613 -- Emit an error concerning the current pragma indicating that it
6614 -- should be placed after pragma Prag.
6616 --------------------
6617 -- Check_Grouping --
6618 --------------------
6620 function Check_Grouping
(L
: List_Id
) return Boolean is
6623 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6626 -- Inspect the list of declarations or statements looking for
6627 -- the first grouping of pragmas:
6630 -- pragma Loop_Invariant ...;
6631 -- pragma Loop_Variant ...;
6633 -- pragma Loop_Variant ...; -- current pragma
6635 -- If the current pragma is not in the grouping, then it must
6636 -- either appear in a different declarative or statement list
6637 -- or the construct at (1) is separating the pragma from the
6641 while Present
(Stmt
) loop
6643 -- First pragma of the first topmost grouping has been found
6645 if Is_Loop_Pragma
(Stmt
) then
6647 -- The group and the current pragma are not in the same
6648 -- declarative or statement list.
6650 if not In_Same_List
(Stmt
, N
) then
6651 Grouping_Error
(Stmt
);
6653 -- Try to reach the current pragma from the first pragma
6654 -- of the grouping while skipping other members:
6656 -- pragma Loop_Invariant ...; -- first pragma
6657 -- pragma Loop_Variant ...; -- member
6659 -- pragma Loop_Variant ...; -- current pragma
6662 while Present
(Stmt
) loop
6663 -- The current pragma is either the first pragma
6664 -- of the group or is a member of the group.
6665 -- Stop the search as the placement is legal.
6670 -- Skip group members, but keep track of the
6671 -- last pragma in the group.
6673 elsif Is_Loop_Pragma
(Stmt
) then
6676 -- Skip Annotate pragmas, typically used to justify
6677 -- unproved loop pragmas in GNATprove.
6679 elsif Nkind
(Stmt
) = N_Pragma
6680 and then Pragma_Name
(Stmt
) = Name_Annotate
6684 -- Skip declarations and statements generated by
6685 -- the compiler during expansion. Note that some
6686 -- source statements (e.g. pragma Assert) may have
6687 -- been transformed so that they do not appear as
6688 -- coming from source anymore, so we instead look
6689 -- at their Original_Node.
6691 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6695 -- A non-pragma is separating the group from the
6696 -- current pragma, the placement is illegal.
6699 Grouping_Error
(Prag
);
6705 -- If the traversal did not reach the current pragma,
6706 -- then the list must be malformed.
6708 raise Program_Error
;
6711 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6712 -- inside a loop or a block housed inside a loop. Inspect
6713 -- the declarations and statements of the block as they may
6714 -- contain the first grouping. This case follows the one for
6715 -- loop pragmas, as block statements which originate in a
6716 -- loop pragma (and so Is_Loop_Pragma will return True on
6717 -- that block statement) should be treated in the previous
6720 elsif Nkind
(Stmt
) = N_Block_Statement
then
6721 HSS
:= Handled_Statement_Sequence
(Stmt
);
6723 if Check_Grouping
(Declarations
(Stmt
)) then
6727 if Present
(HSS
) then
6728 if Check_Grouping
(Statements
(HSS
)) then
6740 --------------------
6741 -- Grouping_Error --
6742 --------------------
6744 procedure Grouping_Error
(Prag
: Node_Id
) is
6746 Error_Msg_Sloc
:= Sloc
(Prag
);
6747 Error_Pragma
("pragma% must appear next to pragma#");
6752 -- Start of processing for Check_Loop_Pragma_Grouping
6755 -- Inspect the statements of the loop or nested blocks housed
6756 -- within to determine whether the current pragma is part of the
6757 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6759 Ignore
:= Check_Grouping
(Statements
(Loop_Stmt
));
6760 end Check_Loop_Pragma_Grouping
;
6762 --------------------
6763 -- Is_Loop_Pragma --
6764 --------------------
6766 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6767 Original_Stmt
: constant Node_Id
:= Original_Node
(Stmt
);
6770 -- Inspect the original node as Loop_Invariant and Loop_Variant
6771 -- pragmas are rewritten to null when assertions are disabled.
6773 return Nkind
(Original_Stmt
) = N_Pragma
6774 and then Pragma_Name_Unmapped
(Original_Stmt
)
6775 in Name_Loop_Invariant | Name_Loop_Variant
;
6778 ---------------------
6779 -- Placement_Error --
6780 ---------------------
6782 procedure Placement_Error
(Constr
: Node_Id
) is
6783 LA
: constant String := " with Loop_Entry";
6786 if Prag_Id
= Pragma_Assert
then
6787 Error_Msg_String
(1 .. LA
'Length) := LA
;
6788 Error_Msg_Strlen
:= LA
'Length;
6790 Error_Msg_Strlen
:= 0;
6793 if Nkind
(Constr
) = N_Pragma
then
6795 ("pragma %~ must appear immediately within the statements "
6799 ("block containing pragma %~ must appear immediately within "
6800 & "the statements of a loop", Constr
);
6802 end Placement_Error
;
6804 -- Local declarations
6809 -- Start of processing for Check_Loop_Pragma_Placement
6812 -- Check that pragma appears immediately within a loop statement,
6813 -- ignoring intervening block statements.
6817 while Present
(Stmt
) loop
6819 -- The pragma or previous block must appear immediately within the
6820 -- current block's declarative or statement part.
6822 if Nkind
(Stmt
) = N_Block_Statement
then
6823 if (No
(Declarations
(Stmt
))
6824 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6826 List_Containing
(Prev
) /=
6827 Statements
(Handled_Statement_Sequence
(Stmt
))
6829 Placement_Error
(Prev
);
6831 -- Keep inspecting the parents because we are now within a
6832 -- chain of nested blocks.
6836 Stmt
:= Parent
(Stmt
);
6839 -- The pragma or previous block must appear immediately within the
6840 -- statements of the loop.
6842 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6843 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6844 Placement_Error
(Prev
);
6847 -- Stop the traversal because we reached the innermost loop
6848 -- regardless of whether we encountered an error or not.
6852 -- Ignore a handled statement sequence. Note that this node may
6853 -- be related to a subprogram body in which case we will emit an
6854 -- error on the next iteration of the search.
6856 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6857 Stmt
:= Parent
(Stmt
);
6859 -- Any other statement breaks the chain from the pragma to the
6863 Placement_Error
(Prev
);
6867 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6868 -- grouped together with other such pragmas.
6870 if Is_Loop_Pragma
(N
) then
6872 -- The previous check should have located the related loop
6874 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6875 Check_Loop_Pragma_Grouping
(Stmt
);
6877 end Check_Loop_Pragma_Placement
;
6879 -------------------------------------------
6880 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6881 -------------------------------------------
6883 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6892 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6895 elsif Nkind
(P
) in N_Package_Specification | N_Block_Statement
then
6898 -- Note: the following tests seem a little peculiar, because
6899 -- they test for bodies, but if we were in the statement part
6900 -- of the body, we would already have hit the handled statement
6901 -- sequence, so the only way we get here is by being in the
6902 -- declarative part of the body.
6905 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6913 Error_Pragma
("pragma% is not in declarative part or package spec");
6914 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6916 -------------------------
6917 -- Check_No_Identifier --
6918 -------------------------
6920 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6922 if Nkind
(Arg
) = N_Pragma_Argument_Association
6923 and then Chars
(Arg
) /= No_Name
6925 Error_Pragma_Arg_Ident
6926 ("pragma% does not permit identifier& here", Arg
);
6928 end Check_No_Identifier
;
6930 --------------------------
6931 -- Check_No_Identifiers --
6932 --------------------------
6934 procedure Check_No_Identifiers
is
6938 for J
in 1 .. Arg_Count
loop
6939 Check_No_Identifier
(Arg_Node
);
6942 end Check_No_Identifiers
;
6944 ------------------------
6945 -- Check_No_Link_Name --
6946 ------------------------
6948 procedure Check_No_Link_Name
is
6950 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6954 if Present
(Arg4
) then
6956 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6958 end Check_No_Link_Name
;
6960 -------------------------------
6961 -- Check_Optional_Identifier --
6962 -------------------------------
6964 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6967 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6968 and then Chars
(Arg
) /= No_Name
6970 if Chars
(Arg
) /= Id
then
6971 Error_Msg_Name_1
:= Pname
;
6972 Error_Msg_Name_2
:= Id
;
6973 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6977 end Check_Optional_Identifier
;
6979 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6981 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6982 end Check_Optional_Identifier
;
6984 -------------------------------------
6985 -- Check_Static_Boolean_Expression --
6986 -------------------------------------
6988 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6990 if Present
(Expr
) then
6991 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6993 if not Is_OK_Static_Expression
(Expr
) then
6995 ("expression of pragma % must be static", Expr
);
6998 end Check_Static_Boolean_Expression
;
7000 -----------------------------
7001 -- Check_Static_Constraint --
7002 -----------------------------
7004 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
7006 procedure Require_Static
(E
: Node_Id
);
7007 -- Require given expression to be static expression
7009 --------------------
7010 -- Require_Static --
7011 --------------------
7013 procedure Require_Static
(E
: Node_Id
) is
7015 if not Is_OK_Static_Expression
(E
) then
7016 Flag_Non_Static_Expr
7017 ("non-static constraint not allowed in Unchecked_Union!", E
);
7022 -- Start of processing for Check_Static_Constraint
7025 case Nkind
(Constr
) is
7026 when N_Discriminant_Association
=>
7027 Require_Static
(Expression
(Constr
));
7030 Require_Static
(Low_Bound
(Constr
));
7031 Require_Static
(High_Bound
(Constr
));
7033 when N_Attribute_Reference
=>
7034 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
7035 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
7037 when N_Range_Constraint
=>
7038 Check_Static_Constraint
(Range_Expression
(Constr
));
7040 when N_Index_Or_Discriminant_Constraint
=>
7044 IDC
:= First
(Constraints
(Constr
));
7045 while Present
(IDC
) loop
7046 Check_Static_Constraint
(IDC
);
7054 end Check_Static_Constraint
;
7056 --------------------------------------
7057 -- Check_Valid_Configuration_Pragma --
7058 --------------------------------------
7060 -- A configuration pragma must appear in the context clause of a
7061 -- compilation unit, and only other pragmas may precede it. Note that
7062 -- the test also allows use in a configuration pragma file.
7064 procedure Check_Valid_Configuration_Pragma
is
7066 if not Is_Configuration_Pragma
then
7067 Error_Pragma
("incorrect placement for configuration pragma%");
7069 end Check_Valid_Configuration_Pragma
;
7071 -------------------------------------
7072 -- Check_Valid_Library_Unit_Pragma --
7073 -------------------------------------
7075 procedure Check_Valid_Library_Unit_Pragma
is
7077 Parent_Node
: Node_Id
;
7078 Unit_Name
: Entity_Id
;
7079 Unit_Kind
: Node_Kind
;
7080 Unit_Node
: Node_Id
;
7081 Sindex
: Source_File_Index
;
7084 if not Is_List_Member
(N
) then
7088 Plist
:= List_Containing
(N
);
7089 Parent_Node
:= Parent
(Plist
);
7091 if Parent_Node
= Empty
then
7094 -- Case of pragma appearing after a compilation unit. In this case
7095 -- it must have an argument with the corresponding name and must
7096 -- be part of the following pragmas of its parent.
7098 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
7099 if Plist
/= Pragmas_After
(Parent_Node
) then
7101 ("pragma% misplaced, must be inside or after the "
7102 & "compilation unit");
7104 elsif Arg_Count
= 0 then
7106 ("argument required if outside compilation unit");
7109 Check_No_Identifiers
;
7110 Check_Arg_Count
(1);
7111 Unit_Node
:= Unit
(Parent
(Parent_Node
));
7112 Unit_Kind
:= Nkind
(Unit_Node
);
7114 Analyze
(Get_Pragma_Arg
(Arg1
));
7116 if Unit_Kind
= N_Generic_Subprogram_Declaration
7117 or else Unit_Kind
= N_Subprogram_Declaration
7119 Unit_Name
:= Defining_Entity
(Unit_Node
);
7121 elsif Unit_Kind
in N_Generic_Instantiation
then
7122 Unit_Name
:= Defining_Entity
(Unit_Node
);
7125 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
7128 if Chars
(Unit_Name
) /=
7129 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
7132 ("pragma% argument is not current unit name", Arg1
);
7135 if Ekind
(Unit_Name
) = E_Package
7136 and then Present
(Renamed_Entity
(Unit_Name
))
7138 Error_Pragma
("pragma% not allowed for renamed package");
7142 -- Pragma appears other than after a compilation unit
7145 -- Here we check for the generic instantiation case and also
7146 -- for the case of processing a generic formal package. We
7147 -- detect these cases by noting that the Sloc on the node
7148 -- does not belong to the current compilation unit.
7150 Sindex
:= Source_Index
(Current_Sem_Unit
);
7152 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
7153 -- We do not want to raise an exception here since this code
7154 -- is part of the bootstrap path where we cannot rely on
7155 -- exception propagation working.
7156 -- Instead the caller should check for N being rewritten as
7157 -- a null statement.
7158 -- This code triggers when compiling a-except.adb.
7160 Rewrite
(N
, Make_Null_Statement
(Loc
));
7162 -- If before first declaration, the pragma applies to the
7163 -- enclosing unit, and the name if present must be this name.
7165 elsif Is_Before_First_Decl
(N
, Plist
) then
7166 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
7167 Unit_Kind
:= Nkind
(Unit_Node
);
7169 if Unit_Node
= Standard_Package_Node
then
7171 ("pragma% misplaced, must be inside or after the "
7172 & "compilation unit");
7174 elsif Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
7176 ("pragma% misplaced, must be on library unit");
7178 elsif Unit_Kind
= N_Subprogram_Body
7179 and then not Acts_As_Spec
(Unit_Node
)
7182 ("pragma% misplaced, must be on the subprogram spec");
7184 elsif Nkind
(Parent_Node
) = N_Package_Body
then
7186 ("pragma% misplaced, must be on the package spec");
7188 elsif Nkind
(Parent_Node
) = N_Package_Specification
7189 and then Plist
= Private_Declarations
(Parent_Node
)
7192 ("pragma% misplaced, must be in the public part");
7194 elsif Nkind
(Parent_Node
) in N_Generic_Declaration
7195 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
7198 ("pragma% misplaced, must not be in formal part");
7200 elsif Arg_Count
> 0 then
7201 Analyze
(Get_Pragma_Arg
(Arg1
));
7203 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
7205 ("name in pragma% must be enclosing unit", Arg1
);
7208 -- It is legal to have no argument in this context
7214 -- Error if not before first declaration. This is because a
7215 -- library unit pragma argument must be the name of a library
7216 -- unit (RM 10.1.5(7)), but the only names permitted in this
7217 -- context are (RM 10.1.5(6)) names of subprogram declarations,
7218 -- generic subprogram declarations or generic instantiations.
7222 ("pragma% misplaced, must be before first declaration");
7226 end Check_Valid_Library_Unit_Pragma
;
7232 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
7233 Clist
: constant Node_Id
:= Component_List
(Variant
);
7237 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
7238 while Present
(Comp
) loop
7239 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
7240 Next_Non_Pragma
(Comp
);
7244 ---------------------------
7245 -- Ensure_Aggregate_Form --
7246 ---------------------------
7248 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
7249 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
7250 Expr
: constant Node_Id
:= Expression
(Arg
);
7251 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7252 Comps
: List_Id
:= No_List
;
7253 Exprs
: List_Id
:= No_List
;
7254 Nam
: Name_Id
:= No_Name
;
7255 Nam_Loc
: Source_Ptr
;
7258 -- The pragma argument is in positional form:
7260 -- pragma Depends (Nam => ...)
7264 -- Note that the Sloc of the Chars field is the Sloc of the pragma
7265 -- argument association.
7267 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
7269 Nam_Loc
:= Sloc
(Arg
);
7271 -- Remove the pragma argument name as this will be captured in the
7274 Set_Chars
(Arg
, No_Name
);
7277 -- The argument is already in aggregate form, but the presence of a
7278 -- name causes this to be interpreted as named association which in
7279 -- turn must be converted into an aggregate.
7281 -- pragma Global (In_Out => (A, B, C))
7285 -- pragma Global ((In_Out => (A, B, C)))
7287 -- aggregate aggregate
7289 if Nkind
(Expr
) = N_Aggregate
then
7290 if Nam
= No_Name
then
7294 -- Do not transform a null argument into an aggregate as N_Null has
7295 -- special meaning in formal verification pragmas.
7297 elsif Nkind
(Expr
) = N_Null
then
7301 -- Everything comes from source if the original comes from source
7303 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
7305 -- Positional argument is transformed into an aggregate with an
7306 -- Expressions list.
7308 if Nam
= No_Name
then
7309 Exprs
:= New_List
(Relocate_Node
(Expr
));
7311 -- An associative argument is transformed into an aggregate with
7312 -- Component_Associations.
7316 Make_Component_Association
(Loc
,
7317 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
7318 Expression
=> Relocate_Node
(Expr
)));
7321 Set_Expression
(Arg
,
7322 Make_Aggregate
(Loc
,
7323 Component_Associations
=> Comps
,
7324 Expressions
=> Exprs
));
7326 -- Restore Comes_From_Source default
7328 Set_Comes_From_Source_Default
(CFSD
);
7329 end Ensure_Aggregate_Form
;
7335 procedure Error_Pragma
(Msg
: String) is
7337 Error_Msg_Name_1
:= Pname
;
7338 Error_Msg_N
(Fix_Error
(Msg
), N
);
7342 ----------------------
7343 -- Error_Pragma_Arg --
7344 ----------------------
7346 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
7348 Error_Msg_Name_1
:= Pname
;
7349 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
7351 end Error_Pragma_Arg
;
7353 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
7355 Error_Msg_Name_1
:= Pname
;
7356 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
7357 Error_Pragma_Arg
(Msg2
, Arg
);
7358 end Error_Pragma_Arg
;
7360 ----------------------------
7361 -- Error_Pragma_Arg_Ident --
7362 ----------------------------
7364 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
7366 Error_Msg_Name_1
:= Pname
;
7367 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
7369 end Error_Pragma_Arg_Ident
;
7371 ----------------------
7372 -- Error_Pragma_Ref --
7373 ----------------------
7375 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
7377 Error_Msg_Name_1
:= Pname
;
7378 Error_Msg_Sloc
:= Sloc
(Ref
);
7379 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
7381 end Error_Pragma_Ref
;
7383 ------------------------
7384 -- Find_Lib_Unit_Name --
7385 ------------------------
7387 function Find_Lib_Unit_Name
return Entity_Id
is
7389 -- Return inner compilation unit entity, for case of nested
7390 -- categorization pragmas. This happens in generic unit.
7392 if Nkind
(Parent
(N
)) = N_Package_Specification
7393 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
7395 return Defining_Entity
(Parent
(N
));
7397 return Current_Scope
;
7399 end Find_Lib_Unit_Name
;
7401 ----------------------------
7402 -- Find_Program_Unit_Name --
7403 ----------------------------
7405 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
7406 Unit_Name
: Entity_Id
;
7407 Unit_Kind
: Node_Kind
;
7408 P
: constant Node_Id
:= Parent
(N
);
7411 if Nkind
(P
) = N_Compilation_Unit
then
7412 Unit_Kind
:= Nkind
(Unit
(P
));
7414 if Unit_Kind
in N_Subprogram_Declaration
7415 | N_Package_Declaration
7416 | N_Generic_Declaration
7418 Unit_Name
:= Defining_Entity
(Unit
(P
));
7420 if Chars
(Id
) = Chars
(Unit_Name
) then
7421 Set_Entity
(Id
, Unit_Name
);
7422 Set_Etype
(Id
, Etype
(Unit_Name
));
7424 Set_Etype
(Id
, Any_Type
);
7426 ("cannot find program unit referenced by pragma%");
7430 Set_Etype
(Id
, Any_Type
);
7431 Error_Pragma
("pragma% inapplicable to this unit");
7437 end Find_Program_Unit_Name
;
7439 -----------------------------------------
7440 -- Find_Unique_Parameterless_Procedure --
7441 -----------------------------------------
7443 function Find_Unique_Parameterless_Procedure
7445 Arg
: Node_Id
) return Entity_Id
7447 Proc
: Entity_Id
:= Empty
;
7450 -- Perform sanity checks on Name
7452 if not Is_Entity_Name
(Name
) then
7454 ("argument of pragma% must be entity name", Arg
);
7456 elsif not Is_Overloaded
(Name
) then
7457 Proc
:= Entity
(Name
);
7459 if Ekind
(Proc
) /= E_Procedure
7460 or else Present
(First_Formal
(Proc
))
7463 ("argument of pragma% must be parameterless procedure", Arg
);
7466 -- Otherwise, search through interpretations looking for one which
7467 -- has no parameters.
7471 Found
: Boolean := False;
7473 Index
: Interp_Index
;
7476 Get_First_Interp
(Name
, Index
, It
);
7477 while Present
(It
.Nam
) loop
7480 if Ekind
(Proc
) = E_Procedure
7481 and then No
(First_Formal
(Proc
))
7483 -- We found an interpretation, note it and continue
7484 -- looking looking to verify it is unique.
7488 Set_Entity
(Name
, Proc
);
7489 Set_Is_Overloaded
(Name
, False);
7491 -- Two procedures with the same name, log an error
7492 -- since the name is ambiguous.
7496 ("ambiguous handler name for pragma%", Arg
);
7500 Get_Next_Interp
(Index
, It
);
7504 -- Issue an error if we haven't found a suitable match for
7508 ("argument of pragma% must be parameterless procedure",
7512 Proc
:= Entity
(Name
);
7518 end Find_Unique_Parameterless_Procedure
;
7524 function Fix_Error
(Msg
: String) return String is
7525 Res
: String (Msg
'Range) := Msg
;
7526 Res_Last
: Natural := Msg
'Last;
7530 -- If we have a rewriting of another pragma, go to that pragma
7532 if Is_Rewrite_Substitution
(N
)
7533 and then Nkind
(Original_Node
(N
)) = N_Pragma
7535 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
7538 -- Case where pragma comes from an aspect specification
7540 if From_Aspect_Specification
(N
) then
7542 -- Change appearance of "pragma" in message to "aspect"
7545 while J
<= Res_Last
- 5 loop
7546 if Res
(J
.. J
+ 5) = "pragma" then
7547 Res
(J
.. J
+ 5) := "aspect";
7555 -- Change "argument of" at start of message to "entity for"
7558 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
7560 Res
(Res
'First .. Res
'First + 9) := "entity for";
7561 Res
(Res
'First + 10 .. Res_Last
- 1) :=
7562 Res
(Res
'First + 11 .. Res_Last
);
7563 Res_Last
:= Res_Last
- 1;
7566 -- Change "argument" at start of message to "entity"
7569 and then Res
(Res
'First .. Res
'First + 7) = "argument"
7571 Res
(Res
'First .. Res
'First + 5) := "entity";
7572 Res
(Res
'First + 6 .. Res_Last
- 2) :=
7573 Res
(Res
'First + 8 .. Res_Last
);
7574 Res_Last
:= Res_Last
- 2;
7577 -- Get name from corresponding aspect
7579 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
7582 -- Return possibly modified message
7584 return Res
(Res
'First .. Res_Last
);
7587 -------------------------
7588 -- Gather_Associations --
7589 -------------------------
7591 procedure Gather_Associations
7593 Args
: out Args_List
)
7598 -- Initialize all parameters to Empty
7600 for J
in Args
'Range loop
7604 -- That's all we have to do if there are no argument associations
7606 if No
(Pragma_Argument_Associations
(N
)) then
7610 -- Otherwise first deal with any positional parameters present
7612 Arg
:= First
(Pragma_Argument_Associations
(N
));
7613 for Index
in Args
'Range loop
7614 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
7615 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7619 -- Positional parameters all processed, if any left, then we
7620 -- have too many positional parameters.
7622 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
7624 ("too many positional associations for pragma%", Arg
);
7627 -- Process named parameters if any are present
7629 while Present
(Arg
) loop
7630 if Chars
(Arg
) = No_Name
then
7632 ("positional association cannot follow named association",
7636 for Index
in Names
'Range loop
7637 if Names
(Index
) = Chars
(Arg
) then
7638 if Present
(Args
(Index
)) then
7640 ("duplicate argument association for pragma%", Arg
);
7642 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7647 if Index
= Names
'Last then
7648 Error_Msg_Name_1
:= Pname
;
7649 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7651 -- Check for possible misspelling
7653 for Index1
in Names
'Range loop
7654 if Is_Bad_Spelling_Of
7655 (Chars
(Arg
), Names
(Index1
))
7657 Error_Msg_Name_1
:= Names
(Index1
);
7658 Error_Msg_N
-- CODEFIX
7659 ("\possible misspelling of%", Arg
);
7671 end Gather_Associations
;
7677 procedure GNAT_Pragma
is
7679 -- We need to check the No_Implementation_Pragmas restriction for
7680 -- the case of a pragma from source. Note that the case of aspects
7681 -- generating corresponding pragmas marks these pragmas as not being
7682 -- from source, so this test also catches that case.
7684 if Comes_From_Source
(N
) then
7685 Check_Restriction
(No_Implementation_Pragmas
, N
);
7689 --------------------------
7690 -- Is_Before_First_Decl --
7691 --------------------------
7693 function Is_Before_First_Decl
7694 (Pragma_Node
: Node_Id
;
7695 Decls
: List_Id
) return Boolean
7697 Item
: Node_Id
:= First
(Decls
);
7700 -- Only other pragmas can come before this pragma, but they might
7701 -- have been rewritten so check the original node.
7704 if No
(Item
) or else Nkind
(Original_Node
(Item
)) /= N_Pragma
then
7707 elsif Item
= Pragma_Node
then
7713 end Is_Before_First_Decl
;
7715 -----------------------------
7716 -- Is_Configuration_Pragma --
7717 -----------------------------
7719 -- A configuration pragma must appear in the context clause of a
7720 -- compilation unit, and only other pragmas may precede it. Note that
7721 -- the test below also permits use in a configuration pragma file.
7723 function Is_Configuration_Pragma
return Boolean is
7725 Par
: constant Node_Id
:= Parent
(N
);
7729 -- Don't evaluate List_Containing (N) if Parent (N) could be
7730 -- an N_Aspect_Specification node.
7732 if not Is_List_Member
(N
) then
7736 Lis
:= List_Containing
(N
);
7738 -- If no parent, then we are in the configuration pragma file,
7739 -- so the placement is definitely appropriate.
7744 -- Otherwise we must be in the context clause of a compilation unit
7745 -- and the only thing allowed before us in the context list is more
7746 -- configuration pragmas.
7748 elsif Nkind
(Par
) = N_Compilation_Unit
7749 and then Context_Items
(Par
) = Lis
7756 elsif Nkind
(Prg
) /= N_Pragma
then
7766 end Is_Configuration_Pragma
;
7768 --------------------------
7769 -- Is_In_Context_Clause --
7770 --------------------------
7772 function Is_In_Context_Clause
return Boolean is
7774 Parent_Node
: Node_Id
;
7777 if Is_List_Member
(N
) then
7778 Plist
:= List_Containing
(N
);
7779 Parent_Node
:= Parent
(Plist
);
7781 return Present
(Parent_Node
)
7782 and then Nkind
(Parent_Node
) = N_Compilation_Unit
7783 and then Context_Items
(Parent_Node
) = Plist
;
7787 end Is_In_Context_Clause
;
7789 ---------------------------------
7790 -- Is_Static_String_Expression --
7791 ---------------------------------
7793 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7794 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7795 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7798 Analyze_And_Resolve
(Argx
);
7800 -- Special case Ada 83, where the expression will never be static,
7801 -- but we will return true if we had a string literal to start with.
7803 if Ada_Version
= Ada_83
then
7806 -- Normal case, true only if we end up with a string literal that
7807 -- is marked as being the result of evaluating a static expression.
7810 return Is_OK_Static_Expression
(Argx
)
7811 and then Nkind
(Argx
) = N_String_Literal
;
7814 end Is_Static_String_Expression
;
7816 ----------------------
7817 -- Pragma_Misplaced --
7818 ----------------------
7820 procedure Pragma_Misplaced
is
7822 Error_Pragma
("incorrect placement of pragma%");
7823 end Pragma_Misplaced
;
7825 ------------------------------------------------
7826 -- Process_Atomic_Independent_Shared_Volatile --
7827 ------------------------------------------------
7829 procedure Process_Atomic_Independent_Shared_Volatile
is
7830 procedure Check_Full_Access_Only
(Ent
: Entity_Id
);
7831 -- Apply legality checks to type or object Ent subject to the
7832 -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
7834 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7835 -- Appropriately set flags on the given entity, either an array or
7836 -- record component, or an object declaration) according to the
7839 procedure Mark_Type
(Ent
: Entity_Id
);
7840 -- Appropriately set flags on the given entity, a type
7842 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7843 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7844 -- no explicit alignment was given, set alignment to unknown, since
7845 -- back end knows what the alignment requirements are for atomic and
7846 -- full access arrays. Note: this is necessary for derived types.
7848 -------------------------
7849 -- Check_Full_Access_Only --
7850 -------------------------
7852 procedure Check_Full_Access_Only
(Ent
: Entity_Id
) is
7855 Full_Access_Subcomponent
: exception;
7856 -- Exception raised if a full access subcomponent is found
7858 Generic_Type_Subcomponent
: exception;
7859 -- Exception raised if a subcomponent with generic type is found
7861 procedure Check_Subcomponents
(Typ
: Entity_Id
);
7862 -- Apply checks to subcomponents recursively
7864 -------------------------
7865 -- Check_Subcomponents --
7866 -------------------------
7868 procedure Check_Subcomponents
(Typ
: Entity_Id
) is
7872 if Is_Array_Type
(Typ
) then
7873 Comp
:= Component_Type
(Typ
);
7875 if Has_Atomic_Components
(Typ
)
7876 or else Is_Full_Access
(Comp
)
7878 raise Full_Access_Subcomponent
;
7880 elsif Is_Generic_Type
(Comp
) then
7881 raise Generic_Type_Subcomponent
;
7884 -- Recurse on the component type
7886 Check_Subcomponents
(Comp
);
7888 elsif Is_Record_Type
(Typ
) then
7889 Comp
:= First_Component_Or_Discriminant
(Typ
);
7890 while Present
(Comp
) loop
7892 if Is_Full_Access
(Comp
)
7893 or else Is_Full_Access
(Etype
(Comp
))
7895 raise Full_Access_Subcomponent
;
7897 elsif Is_Generic_Type
(Etype
(Comp
)) then
7898 raise Generic_Type_Subcomponent
;
7901 -- Recurse on the component type
7903 Check_Subcomponents
(Etype
(Comp
));
7905 Next_Component_Or_Discriminant
(Comp
);
7908 end Check_Subcomponents
;
7910 -- Start of processing for Check_Full_Access_Only
7913 -- Fetch the type in case we are dealing with an object or
7916 if Is_Type
(Ent
) then
7919 pragma Assert
(Is_Object
(Ent
)
7921 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7926 if not Is_Volatile
(Ent
) and then not Is_Volatile
(Typ
) then
7928 ("cannot have Full_Access_Only without Volatile/Atomic "
7932 -- Check all the subcomponents of the type recursively, if any
7934 Check_Subcomponents
(Typ
);
7937 when Full_Access_Subcomponent
=>
7939 ("cannot have Full_Access_Only with full access subcomponent "
7942 when Generic_Type_Subcomponent
=>
7944 ("cannot have Full_Access_Only with subcomponent of generic "
7945 & "type (RM C.6(8.2))");
7947 end Check_Full_Access_Only
;
7949 ------------------------------
7950 -- Mark_Component_Or_Object --
7951 ------------------------------
7953 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7955 if Prag_Id
= Pragma_Atomic
7956 or else Prag_Id
= Pragma_Shared
7957 or else Prag_Id
= Pragma_Volatile_Full_Access
7959 if Prag_Id
= Pragma_Volatile_Full_Access
then
7960 Set_Is_Volatile_Full_Access
(Ent
);
7962 Set_Is_Atomic
(Ent
);
7965 -- If the object declaration has an explicit initialization, a
7966 -- temporary may have to be created to hold the expression, to
7967 -- ensure that access to the object remains atomic.
7969 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7970 and then Present
(Expression
(Parent
(Ent
)))
7972 Set_Has_Delayed_Freeze
(Ent
);
7976 -- Atomic/Shared/Volatile_Full_Access imply Independent
7978 if Prag_Id
/= Pragma_Volatile
then
7979 Set_Is_Independent
(Ent
);
7981 if Prag_Id
= Pragma_Independent
then
7982 Record_Independence_Check
(N
, Ent
);
7986 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7988 if Prag_Id
/= Pragma_Independent
then
7989 Set_Is_Volatile
(Ent
);
7990 Set_Treat_As_Volatile
(Ent
);
7992 end Mark_Component_Or_Object
;
7998 procedure Mark_Type
(Ent
: Entity_Id
) is
8000 -- Attribute belongs on the base type. If the view of the type is
8001 -- currently private, it also belongs on the underlying type.
8003 -- In Ada 2022, the pragma can apply to a formal type, for which
8004 -- there may be no underlying type.
8006 if Prag_Id
= Pragma_Atomic
8007 or else Prag_Id
= Pragma_Shared
8008 or else Prag_Id
= Pragma_Volatile_Full_Access
8010 Set_Atomic_VFA
(Ent
);
8011 Set_Atomic_VFA
(Base_Type
(Ent
));
8013 if not Is_Generic_Type
(Ent
) then
8014 Set_Atomic_VFA
(Underlying_Type
(Ent
));
8018 -- Atomic/Shared/Volatile_Full_Access imply Independent
8020 if Prag_Id
/= Pragma_Volatile
then
8021 Set_Is_Independent
(Ent
);
8022 Set_Is_Independent
(Base_Type
(Ent
));
8024 if not Is_Generic_Type
(Ent
) then
8025 Set_Is_Independent
(Underlying_Type
(Ent
));
8027 if Prag_Id
= Pragma_Independent
then
8028 Record_Independence_Check
(N
, Base_Type
(Ent
));
8033 -- Atomic/Shared/Volatile_Full_Access imply Volatile
8035 if Prag_Id
/= Pragma_Independent
then
8036 Set_Is_Volatile
(Ent
);
8037 Set_Is_Volatile
(Base_Type
(Ent
));
8039 if not Is_Generic_Type
(Ent
) then
8040 Set_Is_Volatile
(Underlying_Type
(Ent
));
8041 Set_Treat_As_Volatile
(Underlying_Type
(Ent
));
8044 Set_Treat_As_Volatile
(Ent
);
8047 -- Apply Volatile to the composite type's individual components,
8050 if Prag_Id
= Pragma_Volatile
8051 and then Is_Record_Type
(Etype
(Ent
))
8056 Comp
:= First_Component
(Ent
);
8057 while Present
(Comp
) loop
8058 Mark_Component_Or_Object
(Comp
);
8060 Next_Component
(Comp
);
8066 --------------------
8067 -- Set_Atomic_VFA --
8068 --------------------
8070 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
8072 if Prag_Id
= Pragma_Volatile_Full_Access
then
8073 Set_Is_Volatile_Full_Access
(Ent
);
8075 Set_Is_Atomic
(Ent
);
8078 if not Has_Alignment_Clause
(Ent
) then
8079 Reinit_Alignment
(Ent
);
8089 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
8092 Check_Ada_83_Warning
;
8093 Check_No_Identifiers
;
8094 Check_Arg_Count
(1);
8095 Check_Arg_Is_Local_Name
(Arg1
);
8096 E_Arg
:= Get_Pragma_Arg
(Arg1
);
8098 if Etype
(E_Arg
) = Any_Type
then
8102 E
:= Entity
(E_Arg
);
8103 Decl
:= Declaration_Node
(E
);
8105 -- A pragma that applies to a Ghost entity becomes Ghost for the
8106 -- purposes of legality checks and removal of ignored Ghost code.
8108 Mark_Ghost_Pragma
(N
, E
);
8110 -- Check duplicate before we chain ourselves
8112 Check_Duplicate_Pragma
(E
);
8114 -- Check the constraints of Full_Access_Only in Ada 2022. Note that
8115 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
8116 -- aspect subsumes the Volatile aspect and 2) nesting is supported
8117 -- for this aspect and the outermost enclosing VFA object prevails.
8119 -- Note also that we used to forbid specifying both Atomic and VFA on
8120 -- the same type or object, but the restriction has been lifted in
8121 -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
8123 if Prag_Id
= Pragma_Volatile_Full_Access
8124 and then From_Aspect_Specification
(N
)
8126 Get_Aspect_Id
(Corresponding_Aspect
(N
)) = Aspect_Full_Access_Only
8128 Check_Full_Access_Only
(E
);
8131 -- The following check is only relevant when SPARK_Mode is on as
8132 -- this is not a standard Ada legality rule. Pragma Volatile can
8133 -- only apply to a full type declaration or an object declaration
8134 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
8135 -- untagged derived types that are rewritten as subtypes of their
8136 -- respective root types.
8139 and then Prag_Id
= Pragma_Volatile
8140 and then Nkind
(Original_Node
(Decl
)) not in
8141 N_Full_Type_Declaration |
8142 N_Formal_Type_Declaration |
8143 N_Object_Declaration |
8144 N_Single_Protected_Declaration |
8145 N_Single_Task_Declaration
8148 ("argument of pragma % must denote a full type or object "
8149 & "declaration", Arg1
);
8152 -- Deal with the case where the pragma/attribute is applied to a type
8155 if Rep_Item_Too_Early
(E
, N
)
8156 or else Rep_Item_Too_Late
(E
, N
)
8160 Check_First_Subtype
(Arg1
);
8165 -- Deal with the case where the pragma/attribute applies to a
8166 -- component or object declaration.
8168 elsif Nkind
(Decl
) = N_Object_Declaration
8169 or else (Nkind
(Decl
) = N_Component_Declaration
8170 and then Original_Record_Component
(E
) = E
)
8172 if Rep_Item_Too_Late
(E
, N
) then
8176 Mark_Component_Or_Object
(E
);
8178 -- In other cases give an error
8181 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
8183 end Process_Atomic_Independent_Shared_Volatile
;
8185 -------------------------------------------
8186 -- Process_Compile_Time_Warning_Or_Error --
8187 -------------------------------------------
8189 procedure Process_Compile_Time_Warning_Or_Error
is
8190 P
: Node_Id
:= Parent
(N
);
8191 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8194 Check_Arg_Count
(2);
8195 Check_No_Identifiers
;
8196 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
8197 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
8199 -- In GNATprove mode, pragma Compile_Time_Error is translated as
8200 -- a Check pragma in GNATprove mode, handled as an assumption in
8201 -- GNATprove. This is correct as the compiler will issue an error
8202 -- if the condition cannot be statically evaluated to False.
8203 -- Compile_Time_Warning are ignored, as the analyzer may not have the
8204 -- same information as the compiler (in particular regarding size of
8205 -- objects decided in gigi) so it makes no sense to issue a warning
8208 if GNATprove_Mode
then
8209 if Prag_Id
= Pragma_Compile_Time_Error
then
8213 -- Implement Compile_Time_Error by generating
8214 -- a corresponding Check pragma:
8216 -- pragma Check (name, condition);
8218 -- where name is the identifier matching the pragma name. So
8219 -- rewrite pragma in this manner and analyze the result.
8221 New_Args
:= New_List
8222 (Make_Pragma_Argument_Association
8224 Expression
=> Make_Identifier
(Loc
, Pname
)),
8225 Make_Pragma_Argument_Association
8227 Expression
=> Arg1x
));
8229 -- Rewrite as Check pragma
8233 Chars
=> Name_Check
,
8234 Pragma_Argument_Associations
=> New_Args
));
8240 Rewrite
(N
, Make_Null_Statement
(Loc
));
8246 -- If the condition is known at compile time (now), validate it now.
8247 -- Otherwise, register the expression for validation after the back
8248 -- end has been called, because it might be known at compile time
8249 -- then. For example, if the expression is "Record_Type'Size /= 32"
8250 -- it might be known after the back end has determined the size of
8251 -- Record_Type. We do not defer validation if we're inside a generic
8252 -- unit, because we will have more information in the instances, and
8253 -- this ultimately applies to the main unit itself, because it is not
8254 -- compiled by the back end when it is generic.
8256 if Compile_Time_Known_Value
(Arg1x
) then
8257 Validate_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
8260 while Present
(P
) and then Nkind
(P
) not in N_Generic_Declaration
8262 if (Nkind
(P
) = N_Subprogram_Body
and then not Acts_As_Spec
(P
))
8263 or else Nkind
(P
) = N_Package_Body
8265 P
:= Parent
(Corresponding_Spec
(P
));
8274 Nkind
(Unit
(Cunit
(Main_Unit
))) not in N_Generic_Declaration
8276 Defer_Compile_Time_Warning_Error_To_BE
(N
);
8279 end Process_Compile_Time_Warning_Or_Error
;
8281 ------------------------
8282 -- Process_Convention --
8283 ------------------------
8285 procedure Process_Convention
8286 (C
: out Convention_Id
;
8287 Ent
: out Entity_Id
)
8291 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
8292 -- Called if we have more than one Export/Import/Convention pragma.
8293 -- This is generally illegal, but we have a special case of allowing
8294 -- Import and Interface to coexist if they specify the convention in
8295 -- a consistent manner. We are allowed to do this, since Interface is
8296 -- an implementation defined pragma, and we choose to do it since we
8297 -- know Rational allows this combination. S is the entity id of the
8298 -- subprogram in question. This procedure also sets the special flag
8299 -- Import_Interface_Present in both pragmas in the case where we do
8300 -- have matching Import and Interface pragmas.
8302 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
8303 -- Set convention in entity E, and also flag that the entity has a
8304 -- convention pragma. If entity is for a private or incomplete type,
8305 -- also set convention and flag on underlying type. This procedure
8306 -- also deals with the special case of C_Pass_By_Copy convention,
8307 -- and error checks for inappropriate convention specification.
8309 -------------------------------
8310 -- Diagnose_Multiple_Pragmas --
8311 -------------------------------
8313 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
8314 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
8318 function Same_Convention
(Decl
: Node_Id
) return Boolean;
8319 -- Decl is a pragma node. This function returns True if this
8320 -- pragma has a first argument that is an identifier with a
8321 -- Chars field corresponding to the Convention_Id C.
8323 function Same_Name
(Decl
: Node_Id
) return Boolean;
8324 -- Decl is a pragma node. This function returns True if this
8325 -- pragma has a second argument that is an identifier with a
8326 -- Chars field that matches the Chars of the current subprogram.
8328 ---------------------
8329 -- Same_Convention --
8330 ---------------------
8332 function Same_Convention
(Decl
: Node_Id
) return Boolean is
8333 Arg1
: constant Node_Id
:=
8334 First
(Pragma_Argument_Associations
(Decl
));
8337 if Present
(Arg1
) then
8339 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
8341 if Nkind
(Arg
) = N_Identifier
8342 and then Is_Convention_Name
(Chars
(Arg
))
8343 and then Get_Convention_Id
(Chars
(Arg
)) = C
8351 end Same_Convention
;
8357 function Same_Name
(Decl
: Node_Id
) return Boolean is
8358 Arg1
: constant Node_Id
:=
8359 First
(Pragma_Argument_Associations
(Decl
));
8367 Arg2
:= Next
(Arg1
);
8374 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
8376 if Nkind
(Arg
) = N_Identifier
8377 and then Chars
(Arg
) = Chars
(S
)
8386 -- Start of processing for Diagnose_Multiple_Pragmas
8391 -- Definitely give message if we have Convention/Export here
8393 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
8396 -- If we have an Import or Export, scan back from pragma to
8397 -- find any previous pragma applying to the same procedure.
8398 -- The scan will be terminated by the start of the list, or
8399 -- hitting the subprogram declaration. This won't allow one
8400 -- pragma to appear in the public part and one in the private
8401 -- part, but that seems very unlikely in practice.
8405 while Present
(Decl
) and then Decl
/= Pdec
loop
8407 -- Look for pragma with same name as us
8409 if Nkind
(Decl
) = N_Pragma
8410 and then Same_Name
(Decl
)
8412 -- Give error if same as our pragma or Export/Convention
8414 if Pragma_Name_Unmapped
(Decl
)
8417 | Pragma_Name_Unmapped
(N
)
8421 -- Case of Import/Interface or the other way round
8423 elsif Pragma_Name_Unmapped
(Decl
)
8424 in Name_Interface | Name_Import
8426 -- Here we know that we have Import and Interface. It
8427 -- doesn't matter which way round they are. See if
8428 -- they specify the same convention. If so, all OK,
8429 -- and set special flags to stop other messages
8431 if Same_Convention
(Decl
) then
8432 Set_Import_Interface_Present
(N
);
8433 Set_Import_Interface_Present
(Decl
);
8436 -- If different conventions, special message
8439 Error_Msg_Sloc
:= Sloc
(Decl
);
8441 ("convention differs from that given#", Arg1
);
8450 -- Give message if needed if we fall through those tests
8451 -- except on Relaxed_RM_Semantics where we let go: either this
8452 -- is a case accepted/ignored by other Ada compilers (e.g.
8453 -- a mix of Convention and Import), or another error will be
8454 -- generated later (e.g. using both Import and Export).
8456 if Err
and not Relaxed_RM_Semantics
then
8458 ("at most one Convention/Export/Import pragma is allowed",
8461 end Diagnose_Multiple_Pragmas
;
8463 --------------------------------
8464 -- Set_Convention_From_Pragma --
8465 --------------------------------
8467 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
8469 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8470 -- for an overridden dispatching operation. Technically this is
8471 -- an amendment and should only be done in Ada 2005 mode. However,
8472 -- this is clearly a mistake, since the problem that is addressed
8473 -- by this AI is that there is a clear gap in the RM.
8475 if Is_Dispatching_Operation
(E
)
8476 and then Present
(Overridden_Operation
(E
))
8477 and then C
/= Convention
(Overridden_Operation
(E
))
8480 ("cannot change convention for overridden dispatching "
8481 & "operation", Arg1
);
8483 -- Special check for convention Stdcall: a dispatching call is not
8484 -- allowed. A dispatching subprogram cannot be used to interface
8485 -- to the Win32 API, so this check actually does not impose any
8486 -- effective restriction.
8488 elsif Is_Dispatching_Operation
(E
)
8489 and then C
= Convention_Stdcall
8491 -- Note: make this unconditional so that if there is more
8492 -- than one call to which the pragma applies, we get a
8493 -- message for each call. Also don't use Error_Pragma,
8494 -- so that we get multiple messages.
8496 Error_Msg_Sloc
:= Sloc
(E
);
8498 ("dispatching subprogram# cannot use Stdcall convention!",
8499 Get_Pragma_Arg
(Arg1
));
8502 -- Set the convention
8504 Set_Convention
(E
, C
);
8505 Set_Has_Convention_Pragma
(E
);
8507 -- For the case of a record base type, also set the convention of
8508 -- any anonymous access types declared in the record which do not
8509 -- currently have a specified convention.
8510 -- Similarly for an array base type and anonymous access types
8513 if Is_Base_Type
(E
) then
8514 if Is_Record_Type
(E
) then
8519 Comp
:= First_Component
(E
);
8520 while Present
(Comp
) loop
8521 if Present
(Etype
(Comp
))
8523 Ekind
(Etype
(Comp
)) in
8524 E_Anonymous_Access_Type |
8525 E_Anonymous_Access_Subprogram_Type
8526 and then not Has_Convention_Pragma
(Comp
)
8528 Set_Convention
(Comp
, C
);
8531 Next_Component
(Comp
);
8535 elsif Is_Array_Type
(E
)
8536 and then Ekind
(Component_Type
(E
)) in
8537 E_Anonymous_Access_Type |
8538 E_Anonymous_Access_Subprogram_Type
8540 Set_Convention
(Designated_Type
(Component_Type
(E
)), C
);
8544 -- Deal with incomplete/private type case, where underlying type
8545 -- is available, so set convention of that underlying type.
8547 if Is_Incomplete_Or_Private_Type
(E
)
8548 and then Present
(Underlying_Type
(E
))
8550 Set_Convention
(Underlying_Type
(E
), C
);
8551 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
8554 -- A class-wide type should inherit the convention of the specific
8555 -- root type (although this isn't specified clearly by the RM).
8557 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
8558 Set_Convention
(Class_Wide_Type
(E
), C
);
8561 -- If the entity is a record type, then check for special case of
8562 -- C_Pass_By_Copy, which is treated the same as C except that the
8563 -- special record flag is set. This convention is only permitted
8564 -- on record types (see AI95-00131).
8566 if Cname
= Name_C_Pass_By_Copy
then
8567 if Is_Record_Type
(E
) then
8568 Set_C_Pass_By_Copy
(Base_Type
(E
));
8569 elsif Is_Incomplete_Or_Private_Type
(E
)
8570 and then Is_Record_Type
(Underlying_Type
(E
))
8572 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
8575 ("C_Pass_By_Copy convention allowed only for record type",
8580 -- If the entity is a derived boolean type, check for the special
8581 -- case of convention C, C++, or Fortran, where we consider any
8582 -- nonzero value to represent true.
8584 if Is_Discrete_Type
(E
)
8585 and then Root_Type
(Etype
(E
)) = Standard_Boolean
8591 C
= Convention_Fortran
)
8593 Set_Nonzero_Is_True
(Base_Type
(E
));
8595 end Set_Convention_From_Pragma
;
8599 Comp_Unit
: Unit_Number_Type
;
8605 -- Start of processing for Process_Convention
8608 Check_At_Least_N_Arguments
(2);
8609 Check_Optional_Identifier
(Arg1
, Name_Convention
);
8610 Check_Arg_Is_Identifier
(Arg1
);
8611 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
8613 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8614 -- tested again below to set the critical flag).
8616 if Cname
= Name_C_Pass_By_Copy
then
8619 -- Otherwise we must have something in the standard convention list
8621 elsif Is_Convention_Name
(Cname
) then
8622 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8624 -- Otherwise warn on unrecognized convention
8627 if Warn_On_Export_Import
then
8629 ("??unrecognized convention name, C assumed",
8630 Get_Pragma_Arg
(Arg1
));
8636 Check_Optional_Identifier
(Arg2
, Name_Entity
);
8637 Check_Arg_Is_Local_Name
(Arg2
);
8639 Id
:= Get_Pragma_Arg
(Arg2
);
8642 if not Is_Entity_Name
(Id
) then
8643 Error_Pragma_Arg
("entity name required", Arg2
);
8648 -- Set entity to return
8652 -- Ada_Pass_By_Copy special checking
8654 if C
= Convention_Ada_Pass_By_Copy
then
8655 if not Is_First_Subtype
(E
) then
8657 ("convention `Ada_Pass_By_Copy` only allowed for types",
8661 if Is_By_Reference_Type
(E
) then
8663 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8667 -- Ada_Pass_By_Reference special checking
8669 elsif C
= Convention_Ada_Pass_By_Reference
then
8670 if not Is_First_Subtype
(E
) then
8672 ("convention `Ada_Pass_By_Reference` only allowed for types",
8676 if Is_By_Copy_Type
(E
) then
8678 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8683 -- Go to renamed subprogram if present, since convention applies to
8684 -- the actual renamed entity, not to the renaming entity. If the
8685 -- subprogram is inherited, go to parent subprogram.
8687 if Is_Subprogram
(E
)
8688 and then Present
(Alias
(E
))
8690 if Nkind
(Parent
(Declaration_Node
(E
))) =
8691 N_Subprogram_Renaming_Declaration
8693 if Scope
(E
) /= Scope
(Alias
(E
)) then
8695 ("cannot apply pragma% to non-local entity&#", E
);
8700 elsif Nkind
(Parent
(E
)) in
8701 N_Full_Type_Declaration | N_Private_Extension_Declaration
8702 and then Scope
(E
) = Scope
(Alias
(E
))
8706 -- Return the parent subprogram the entity was inherited from
8712 -- Check that we are not applying this to a specless body. Relax this
8713 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8715 if Is_Subprogram
(E
)
8716 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8717 and then not Relaxed_RM_Semantics
8720 ("pragma% requires separate spec and must come before body");
8723 -- Check that we are not applying this to a named constant
8725 if Is_Named_Number
(E
) then
8726 Error_Msg_Name_1
:= Pname
;
8728 ("cannot apply pragma% to named constant!",
8729 Get_Pragma_Arg
(Arg2
));
8731 ("\supply appropriate type for&!", Arg2
);
8734 if Ekind
(E
) = E_Enumeration_Literal
then
8735 Error_Pragma
("enumeration literal not allowed for pragma%");
8738 -- Check for rep item appearing too early or too late
8740 if Etype
(E
) = Any_Type
8741 or else Rep_Item_Too_Early
(E
, N
)
8745 elsif Present
(Underlying_Type
(E
)) then
8746 E
:= Underlying_Type
(E
);
8749 if Rep_Item_Too_Late
(E
, N
) then
8753 if Has_Convention_Pragma
(E
) then
8754 Diagnose_Multiple_Pragmas
(E
);
8756 elsif Convention
(E
) = Convention_Protected
8757 or else Ekind
(Scope
(E
)) = E_Protected_Type
8760 ("a protected operation cannot be given a different convention",
8764 -- For Intrinsic, a subprogram is required
8766 if C
= Convention_Intrinsic
8767 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8769 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8771 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8772 if From_Aspect_Specification
(N
) then
8774 ("entity for aspect% must be a subprogram", Arg2
);
8777 ("second argument of pragma% must be a subprogram", Arg2
);
8781 -- Special checks for C_Variadic_n
8783 elsif C
in Convention_C_Variadic
then
8785 -- Several allowed cases
8787 if Is_Subprogram_Or_Generic_Subprogram
(E
) then
8790 -- An access to subprogram is also allowed
8792 elsif Is_Access_Type
(E
)
8793 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
8795 Subp
:= Designated_Type
(E
);
8797 -- Allow internal call to set convention of subprogram type
8799 elsif Ekind
(E
) = E_Subprogram_Type
then
8804 ("argument of pragma% must be subprogram or access type",
8808 -- ISO C requires a named parameter before the ellipsis, so a
8809 -- variadic C function taking 0 fixed parameter cannot exist.
8811 if C
= Convention_C_Variadic_0
then
8814 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8815 Get_Pragma_Arg
(Arg2
));
8817 -- Now check the number of parameters of the subprogram and give
8818 -- an error if it is lower than n.
8820 elsif Present
(Subp
) then
8822 Minimum
: constant Nat
:=
8823 Convention_Id
'Pos (C
) -
8824 Convention_Id
'Pos (Convention_C_Variadic_0
);
8831 Formal
:= First_Formal
(Subp
);
8832 while Present
(Formal
) loop
8834 Next_Formal
(Formal
);
8837 if Count
< Minimum
then
8838 Error_Msg_Uint_1
:= UI_From_Int
(Minimum
);
8840 ("argument of pragma% must have at least"
8841 & "^ parameters", Arg2
);
8846 -- Special checks for Stdcall
8848 elsif C
= Convention_Stdcall
then
8850 -- Several allowed cases
8852 if Is_Subprogram_Or_Generic_Subprogram
(E
)
8856 or else Ekind
(E
) = E_Variable
8858 -- A component as well. The entity does not have its Ekind
8859 -- set until the enclosing record declaration is fully
8862 or else Nkind
(Parent
(E
)) = N_Component_Declaration
8864 -- An access to subprogram is also allowed
8868 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
8870 -- Allow internal call to set convention of subprogram type
8872 or else Ekind
(E
) = E_Subprogram_Type
8878 ("argument of pragma% must be subprogram or access type",
8883 Set_Convention_From_Pragma
(E
);
8885 -- Deal with non-subprogram cases
8887 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8890 -- The pragma must apply to a first subtype, but it can also
8891 -- apply to a generic type in a generic formal part, in which
8892 -- case it will also appear in the corresponding instance.
8894 if Is_Generic_Type
(E
) or else In_Instance
then
8897 Check_First_Subtype
(Arg2
);
8900 Set_Convention_From_Pragma
(Base_Type
(E
));
8902 -- For access subprograms, we must set the convention on the
8903 -- internally generated directly designated type as well.
8905 if Ekind
(E
) = E_Access_Subprogram_Type
then
8906 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8910 -- For the subprogram case, set proper convention for all homonyms
8911 -- in same scope and the same declarative part, i.e. the same
8912 -- compilation unit.
8915 -- Treat a pragma Import as an implicit body, and pragma import
8916 -- as implicit reference (for navigation in GNAT Studio).
8918 if Prag_Id
= Pragma_Import
then
8919 Generate_Reference
(E
, Id
, 'b');
8921 -- For exported entities we restrict the generation of references
8922 -- to entities exported to foreign languages since entities
8923 -- exported to Ada do not provide further information to
8924 -- GNAT Studio and add undesired references to the output of the
8927 elsif Prag_Id
= Pragma_Export
8928 and then Convention
(E
) /= Convention_Ada
8930 Generate_Reference
(E
, Id
, 'i');
8933 -- If the pragma comes from an aspect, it only applies to the
8934 -- given entity, not its homonyms.
8936 if From_Aspect_Specification
(N
) then
8937 if C
= Convention_Intrinsic
8938 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8940 if Is_Fixed_Point_Type
(Etype
(Ent
))
8941 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8942 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8945 ("no intrinsic operator available for this fixed-point "
8948 ("\use expression functions with the desired "
8949 & "conversions made explicit", N
);
8956 -- Otherwise Loop through the homonyms of the pragma argument's
8957 -- entity, an apply convention to those in the current scope.
8959 Comp_Unit
:= Get_Source_Unit
(E
);
8964 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8966 -- Ignore entry for which convention is already set
8968 if Has_Convention_Pragma
(E1
) then
8972 if Is_Subprogram
(E1
)
8973 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8975 and then not Relaxed_RM_Semantics
8977 Set_Has_Completion
(E
); -- to prevent cascaded error
8979 ("pragma% requires separate spec and must come before "
8983 -- Do not set the pragma on inherited operations or on formal
8986 if Comes_From_Source
(E1
)
8987 and then Comp_Unit
= Get_Source_Unit
(E1
)
8988 and then not Is_Formal_Subprogram
(E1
)
8989 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8990 N_Full_Type_Declaration
8992 if Present
(Alias
(E1
))
8993 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8996 ("cannot apply pragma% to non-local entity& declared#",
9000 Set_Convention_From_Pragma
(E1
);
9002 if Prag_Id
= Pragma_Import
then
9003 Generate_Reference
(E1
, Id
, 'b');
9011 end Process_Convention
;
9013 ----------------------------------------
9014 -- Process_Disable_Enable_Atomic_Sync --
9015 ----------------------------------------
9017 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
9019 Check_No_Identifiers
;
9020 Check_At_Most_N_Arguments
(1);
9022 -- Modeled internally as
9023 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
9028 Pragma_Argument_Associations
=> New_List
(
9029 Make_Pragma_Argument_Association
(Loc
,
9031 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
9033 if Present
(Arg1
) then
9034 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
9038 end Process_Disable_Enable_Atomic_Sync
;
9040 -------------------------------------------------
9041 -- Process_Extended_Import_Export_Internal_Arg --
9042 -------------------------------------------------
9044 procedure Process_Extended_Import_Export_Internal_Arg
9045 (Arg_Internal
: Node_Id
:= Empty
)
9048 if No
(Arg_Internal
) then
9049 Error_Pragma
("Internal parameter required for pragma%");
9052 if Nkind
(Arg_Internal
) = N_Identifier
then
9055 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
9056 and then (Prag_Id
= Pragma_Import_Function
9058 Prag_Id
= Pragma_Export_Function
)
9064 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
9067 Check_Arg_Is_Local_Name
(Arg_Internal
);
9068 end Process_Extended_Import_Export_Internal_Arg
;
9070 --------------------------------------------------
9071 -- Process_Extended_Import_Export_Object_Pragma --
9072 --------------------------------------------------
9074 procedure Process_Extended_Import_Export_Object_Pragma
9075 (Arg_Internal
: Node_Id
;
9076 Arg_External
: Node_Id
;
9082 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
9083 Def_Id
:= Entity
(Arg_Internal
);
9085 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
9087 ("pragma% must designate an object", Arg_Internal
);
9090 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
9092 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
9095 ("previous Common/Psect_Object applies, pragma % not permitted",
9099 if Rep_Item_Too_Late
(Def_Id
, N
) then
9103 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
9105 if Present
(Arg_Size
) then
9106 Check_Arg_Is_External_Name
(Arg_Size
);
9109 -- Export_Object case
9111 if Prag_Id
= Pragma_Export_Object
then
9112 if not Is_Library_Level_Entity
(Def_Id
) then
9114 ("argument for pragma% must be library level entity",
9118 if Ekind
(Current_Scope
) = E_Generic_Package
then
9119 Error_Pragma
("pragma& cannot appear in a generic unit");
9122 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
9124 ("exported object must have compile time known size",
9128 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
9129 Error_Msg_N
("??duplicate Export_Object pragma", N
);
9131 Set_Exported
(Def_Id
, Arg_Internal
);
9134 -- Import_Object case
9137 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
9139 ("cannot use pragma% for task/protected object",
9143 if Ekind
(Def_Id
) = E_Constant
then
9145 ("cannot import a constant", Arg_Internal
);
9148 if Warn_On_Export_Import
9149 and then Has_Discriminants
(Etype
(Def_Id
))
9152 ("imported value must be initialized??", Arg_Internal
);
9155 if Warn_On_Export_Import
9156 and then Is_Access_Type
(Etype
(Def_Id
))
9159 ("cannot import object of an access type??", Arg_Internal
);
9162 if Warn_On_Export_Import
9163 and then Is_Imported
(Def_Id
)
9165 Error_Msg_N
("??duplicate Import_Object pragma", N
);
9167 -- Check for explicit initialization present. Note that an
9168 -- initialization generated by the code generator, e.g. for an
9169 -- access type, does not count here.
9171 elsif Present
(Expression
(Parent
(Def_Id
)))
9174 (Original_Node
(Expression
(Parent
(Def_Id
))))
9176 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9178 ("imported entities cannot be initialized (RM B.1(24))",
9179 "\no initialization allowed for & declared#", Arg1
);
9181 Set_Imported
(Def_Id
);
9182 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
9185 end Process_Extended_Import_Export_Object_Pragma
;
9187 ------------------------------------------------------
9188 -- Process_Extended_Import_Export_Subprogram_Pragma --
9189 ------------------------------------------------------
9191 procedure Process_Extended_Import_Export_Subprogram_Pragma
9192 (Arg_Internal
: Node_Id
;
9193 Arg_External
: Node_Id
;
9194 Arg_Parameter_Types
: Node_Id
;
9195 Arg_Result_Type
: Node_Id
:= Empty
;
9196 Arg_Mechanism
: Node_Id
;
9197 Arg_Result_Mechanism
: Node_Id
:= Empty
)
9203 Ambiguous
: Boolean;
9206 function Same_Base_Type
9208 Formal
: Entity_Id
) return Boolean;
9209 -- Determines if Ptype references the type of Formal. Note that only
9210 -- the base types need to match according to the spec. Ptype here is
9211 -- the argument from the pragma, which is either a type name, or an
9212 -- access attribute.
9214 --------------------
9215 -- Same_Base_Type --
9216 --------------------
9218 function Same_Base_Type
9220 Formal
: Entity_Id
) return Boolean
9222 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
9226 -- Case where pragma argument is typ'Access
9228 if Nkind
(Ptype
) = N_Attribute_Reference
9229 and then Attribute_Name
(Ptype
) = Name_Access
9231 Pref
:= Prefix
(Ptype
);
9234 if not Is_Entity_Name
(Pref
)
9235 or else Entity
(Pref
) = Any_Type
9240 -- We have a match if the corresponding argument is of an
9241 -- anonymous access type, and its designated type matches the
9242 -- type of the prefix of the access attribute
9244 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
9245 and then Base_Type
(Entity
(Pref
)) =
9246 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
9248 -- Case where pragma argument is a type name
9253 if not Is_Entity_Name
(Ptype
)
9254 or else Entity
(Ptype
) = Any_Type
9259 -- We have a match if the corresponding argument is of the type
9260 -- given in the pragma (comparing base types)
9262 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
9266 -- Start of processing for
9267 -- Process_Extended_Import_Export_Subprogram_Pragma
9270 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
9274 -- Loop through homonyms (overloadings) of the entity
9276 Hom_Id
:= Entity
(Arg_Internal
);
9277 while Present
(Hom_Id
) loop
9278 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9280 -- We need a subprogram in the current scope
9282 if not Is_Subprogram
(Def_Id
)
9283 or else Scope
(Def_Id
) /= Current_Scope
9290 -- Pragma cannot apply to subprogram body
9292 if Is_Subprogram
(Def_Id
)
9293 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
9297 ("pragma% requires separate spec and must come before "
9301 -- Test result type if given, note that the result type
9302 -- parameter can only be present for the function cases.
9304 if Present
(Arg_Result_Type
)
9305 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
9309 elsif Etype
(Def_Id
) /= Standard_Void_Type
9311 Pname
in Name_Export_Procedure | Name_Import_Procedure
9315 -- Test parameter types if given. Note that this parameter has
9316 -- not been analyzed (and must not be, since it is semantic
9317 -- nonsense), so we get it as the parser left it.
9319 elsif Present
(Arg_Parameter_Types
) then
9320 Check_Matching_Types
: declare
9325 Formal
:= First_Formal
(Def_Id
);
9327 if Nkind
(Arg_Parameter_Types
) = N_Null
then
9328 if Present
(Formal
) then
9332 -- A list of one type, e.g. (List) is parsed as a
9333 -- parenthesized expression.
9335 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
9336 and then Paren_Count
(Arg_Parameter_Types
) = 1
9339 or else Present
(Next_Formal
(Formal
))
9344 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
9347 -- A list of more than one type is parsed as a aggregate
9349 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
9350 and then Paren_Count
(Arg_Parameter_Types
) = 0
9352 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
9353 while Present
(Ptype
) or else Present
(Formal
) loop
9356 or else not Same_Base_Type
(Ptype
, Formal
)
9361 Next_Formal
(Formal
);
9366 -- Anything else is of the wrong form
9370 ("wrong form for Parameter_Types parameter",
9371 Arg_Parameter_Types
);
9373 end Check_Matching_Types
;
9376 -- Match is now False if the entry we found did not match
9377 -- either a supplied Parameter_Types or Result_Types argument
9383 -- Ambiguous case, the flag Ambiguous shows if we already
9384 -- detected this and output the initial messages.
9387 if not Ambiguous
then
9389 Error_Msg_Name_1
:= Pname
;
9391 ("pragma% does not uniquely identify subprogram!",
9393 Error_Msg_Sloc
:= Sloc
(Ent
);
9394 Error_Msg_N
("matching subprogram #!", N
);
9398 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9399 Error_Msg_N
("matching subprogram #!", N
);
9404 Hom_Id
:= Homonym
(Hom_Id
);
9407 -- See if we found an entry
9410 if not Ambiguous
then
9411 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
9413 ("pragma% cannot be given for generic subprogram");
9416 ("pragma% does not identify local subprogram");
9423 -- Import pragmas must be for imported entities
9425 if Prag_Id
= Pragma_Import_Function
9427 Prag_Id
= Pragma_Import_Procedure
9429 Prag_Id
= Pragma_Import_Valued_Procedure
9431 if not Is_Imported
(Ent
) then
9433 ("pragma Import or Interface must precede pragma%");
9436 -- Here we have the Export case which can set the entity as exported
9438 -- But does not do so if the specified external name is null, since
9439 -- that is taken as a signal in DEC Ada 83 (with which we want to be
9440 -- compatible) to request no external name.
9442 elsif Nkind
(Arg_External
) = N_String_Literal
9443 and then String_Length
(Strval
(Arg_External
)) = 0
9447 -- In all other cases, set entity as exported
9450 Set_Exported
(Ent
, Arg_Internal
);
9453 -- Special processing for Valued_Procedure cases
9455 if Prag_Id
= Pragma_Import_Valued_Procedure
9457 Prag_Id
= Pragma_Export_Valued_Procedure
9459 Formal
:= First_Formal
(Ent
);
9462 Error_Pragma
("at least one parameter required for pragma%");
9464 elsif Ekind
(Formal
) /= E_Out_Parameter
then
9465 Error_Pragma
("first parameter must have mode OUT for pragma%");
9468 Set_Is_Valued_Procedure
(Ent
);
9472 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
9474 -- Process Result_Mechanism argument if present. We have already
9475 -- checked that this is only allowed for the function case.
9477 if Present
(Arg_Result_Mechanism
) then
9478 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
9481 -- Process Mechanism parameter if present. Note that this parameter
9482 -- is not analyzed, and must not be analyzed since it is semantic
9483 -- nonsense, so we get it in exactly as the parser left it.
9485 if Present
(Arg_Mechanism
) then
9493 -- A single mechanism association without a formal parameter
9494 -- name is parsed as a parenthesized expression. All other
9495 -- cases are parsed as aggregates, so we rewrite the single
9496 -- parameter case as an aggregate for consistency.
9498 if Nkind
(Arg_Mechanism
) /= N_Aggregate
9499 and then Paren_Count
(Arg_Mechanism
) = 1
9501 Rewrite
(Arg_Mechanism
,
9502 Make_Aggregate
(Sloc
(Arg_Mechanism
),
9503 Expressions
=> New_List
(
9504 Relocate_Node
(Arg_Mechanism
))));
9507 -- Case of only mechanism name given, applies to all formals
9509 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
9510 Formal
:= First_Formal
(Ent
);
9511 while Present
(Formal
) loop
9512 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
9513 Next_Formal
(Formal
);
9516 -- Case of list of mechanism associations given
9519 if Null_Record_Present
(Arg_Mechanism
) then
9521 ("inappropriate form for Mechanism parameter",
9525 -- Deal with positional ones first
9527 Formal
:= First_Formal
(Ent
);
9529 if Present
(Expressions
(Arg_Mechanism
)) then
9530 Mname
:= First
(Expressions
(Arg_Mechanism
));
9531 while Present
(Mname
) loop
9534 ("too many mechanism associations", Mname
);
9537 Set_Mechanism_Value
(Formal
, Mname
);
9538 Next_Formal
(Formal
);
9543 -- Deal with named entries
9545 if Present
(Component_Associations
(Arg_Mechanism
)) then
9546 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
9547 while Present
(Massoc
) loop
9548 Choice
:= First
(Choices
(Massoc
));
9550 if Nkind
(Choice
) /= N_Identifier
9551 or else Present
(Next
(Choice
))
9554 ("incorrect form for mechanism association",
9558 Formal
:= First_Formal
(Ent
);
9562 ("parameter name & not present", Choice
);
9565 if Chars
(Choice
) = Chars
(Formal
) then
9567 (Formal
, Expression
(Massoc
));
9569 -- Set entity on identifier for proper tree
9572 Set_Entity
(Choice
, Formal
);
9577 Next_Formal
(Formal
);
9586 end Process_Extended_Import_Export_Subprogram_Pragma
;
9588 --------------------------
9589 -- Process_Generic_List --
9590 --------------------------
9592 procedure Process_Generic_List
is
9597 Check_No_Identifiers
;
9598 Check_At_Least_N_Arguments
(1);
9600 -- Check all arguments are names of generic units or instances
9603 while Present
(Arg
) loop
9604 Exp
:= Get_Pragma_Arg
(Arg
);
9607 if not Is_Entity_Name
(Exp
)
9609 (not Is_Generic_Instance
(Entity
(Exp
))
9611 not Is_Generic_Unit
(Entity
(Exp
)))
9614 ("pragma% argument must be name of generic unit/instance",
9620 end Process_Generic_List
;
9622 ------------------------------------
9623 -- Process_Import_Predefined_Type --
9624 ------------------------------------
9626 procedure Process_Import_Predefined_Type
is
9627 Loc
: constant Source_Ptr
:= Sloc
(N
);
9629 Ftyp
: Node_Id
:= Empty
;
9635 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
9637 Elmt
:= First_Elmt
(Predefined_Float_Types
);
9638 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
9642 Ftyp
:= Node
(Elmt
);
9644 if Present
(Ftyp
) then
9646 -- Don't build a derived type declaration, because predefined C
9647 -- types have no declaration anywhere, so cannot really be named.
9648 -- Instead build a full type declaration, starting with an
9649 -- appropriate type definition is built
9651 if Is_Floating_Point_Type
(Ftyp
) then
9652 Def
:= Make_Floating_Point_Definition
(Loc
,
9653 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
9654 Make_Real_Range_Specification
(Loc
,
9655 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
9656 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
9658 -- Should never have a predefined type we cannot handle
9661 raise Program_Error
;
9664 -- Build and insert a Full_Type_Declaration, which will be
9665 -- analyzed as soon as this list entry has been analyzed.
9667 Decl
:= Make_Full_Type_Declaration
(Loc
,
9668 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
9669 Type_Definition
=> Def
);
9671 Insert_After
(N
, Decl
);
9672 Mark_Rewrite_Insertion
(Decl
);
9675 Error_Pragma_Arg
("no matching type found for pragma%", Arg2
);
9677 end Process_Import_Predefined_Type
;
9679 ---------------------------------
9680 -- Process_Import_Or_Interface --
9681 ---------------------------------
9683 procedure Process_Import_Or_Interface
is
9689 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9690 -- pragma Import (Entity, "external name");
9692 if Relaxed_RM_Semantics
9693 and then Arg_Count
= 2
9694 and then Prag_Id
= Pragma_Import
9695 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
9698 Def_Id
:= Get_Pragma_Arg
(Arg1
);
9701 if not Is_Entity_Name
(Def_Id
) then
9702 Error_Pragma_Arg
("entity name required", Arg1
);
9705 Def_Id
:= Entity
(Def_Id
);
9706 Kill_Size_Check_Code
(Def_Id
);
9707 if Ekind
(Def_Id
) /= E_Constant
then
9708 Note_Possible_Modification
9709 (Get_Pragma_Arg
(Arg1
), Sure
=> False);
9713 Process_Convention
(C
, Def_Id
);
9715 -- A pragma that applies to a Ghost entity becomes Ghost for the
9716 -- purposes of legality checks and removal of ignored Ghost code.
9718 Mark_Ghost_Pragma
(N
, Def_Id
);
9719 Kill_Size_Check_Code
(Def_Id
);
9720 if Ekind
(Def_Id
) /= E_Constant
then
9721 Note_Possible_Modification
9722 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
9726 -- Various error checks
9728 if Ekind
(Def_Id
) in E_Variable | E_Constant
then
9730 -- We do not permit Import to apply to a renaming declaration
9732 if Present
(Renamed_Object
(Def_Id
)) then
9734 ("pragma% not allowed for object renaming", Arg2
);
9736 -- User initialization is not allowed for imported object, but
9737 -- the object declaration may contain a default initialization,
9738 -- that will be discarded. Note that an explicit initialization
9739 -- only counts if it comes from source, otherwise it is simply
9740 -- the code generator making an implicit initialization explicit.
9742 elsif Present
(Expression
(Parent
(Def_Id
)))
9743 and then Comes_From_Source
9744 (Original_Node
(Expression
(Parent
(Def_Id
))))
9746 -- Set imported flag to prevent cascaded errors
9748 Set_Is_Imported
(Def_Id
);
9750 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9752 ("no initialization allowed for declaration of& #",
9753 "\imported entities cannot be initialized (RM B.1(24))",
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 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9766 -- Note that we do not set Is_Public here. That's because we
9767 -- only want to set it if there is no address clause, and we
9768 -- don't know that yet, so we delay that processing till
9771 -- pragma Import completes deferred constants
9773 if Ekind
(Def_Id
) = E_Constant
then
9774 Set_Has_Completion
(Def_Id
);
9777 -- It is not possible to import a constant of an unconstrained
9778 -- array type (e.g. string) because there is no simple way to
9779 -- write a meaningful subtype for it.
9781 if Is_Array_Type
(Etype
(Def_Id
))
9782 and then not Is_Constrained
(Etype
(Def_Id
))
9785 ("imported constant& must have a constrained subtype",
9790 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9792 -- If the name is overloaded, pragma applies to all of the denoted
9793 -- entities in the same declarative part, unless the pragma comes
9794 -- from an aspect specification or was generated by the compiler
9795 -- (such as for pragma Provide_Shift_Operators).
9798 while Present
(Hom_Id
) loop
9800 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9802 -- Ignore inherited subprograms because the pragma will apply
9803 -- to the parent operation, which is the one called.
9805 if Is_Overloadable
(Def_Id
)
9806 and then Present
(Alias
(Def_Id
))
9810 -- If it is not a subprogram, it must be in an outer scope and
9811 -- pragma does not apply.
9813 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9816 -- The pragma does not apply to primitives of interfaces
9818 elsif Is_Dispatching_Operation
(Def_Id
)
9819 and then Present
(Find_Dispatching_Type
(Def_Id
))
9820 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9824 -- Verify that the homonym is in the same declarative part (not
9825 -- just the same scope). If the pragma comes from an aspect
9826 -- specification we know that it is part of the declaration.
9828 elsif (No
(Unit_Declaration_Node
(Def_Id
))
9829 or else Parent
(Unit_Declaration_Node
(Def_Id
)) /=
9831 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9832 and then not From_Aspect_Specification
(N
)
9837 -- If the pragma comes from an aspect specification the
9838 -- Is_Imported flag has already been set.
9840 if not From_Aspect_Specification
(N
) then
9841 Set_Imported
(Def_Id
);
9844 -- Reject an Import applied to an abstract subprogram
9846 if Is_Subprogram
(Def_Id
)
9847 and then Is_Abstract_Subprogram
(Def_Id
)
9849 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9851 ("cannot import abstract subprogram& declared#",
9855 -- Special processing for Convention_Intrinsic
9857 if C
= Convention_Intrinsic
then
9859 -- Link_Name argument not allowed for intrinsic
9863 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9865 -- If no external name is present, then check that this
9866 -- is a valid intrinsic subprogram. If an external name
9867 -- is present, then this is handled by the back end.
9870 Check_Intrinsic_Subprogram
9871 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9875 -- Verify that the subprogram does not have a completion
9876 -- through a renaming declaration. For other completions the
9877 -- pragma appears as a too late representation.
9880 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9884 and then Nkind
(Decl
) = N_Subprogram_Declaration
9885 and then Present
(Corresponding_Body
(Decl
))
9886 and then Nkind
(Unit_Declaration_Node
9887 (Corresponding_Body
(Decl
))) =
9888 N_Subprogram_Renaming_Declaration
9890 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9892 ("cannot import&, renaming already provided for "
9893 & "declaration #", N
, Def_Id
);
9897 -- If the pragma comes from an aspect specification, there
9898 -- must be an Import aspect specified as well. In the rare
9899 -- case where Import is set to False, the subprogram needs
9900 -- to have a local completion.
9903 Imp_Aspect
: constant Node_Id
:=
9904 Find_Aspect
(Def_Id
, Aspect_Import
);
9908 if Present
(Imp_Aspect
)
9909 and then Present
(Expression
(Imp_Aspect
))
9911 Expr
:= Expression
(Imp_Aspect
);
9912 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9914 if Is_Entity_Name
(Expr
)
9915 and then Entity
(Expr
) = Standard_True
9917 Set_Has_Completion
(Def_Id
);
9920 -- If there is no expression, the default is True, as for
9921 -- all boolean aspects. Same for the older pragma.
9924 Set_Has_Completion
(Def_Id
);
9928 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9931 if Is_Compilation_Unit
(Hom_Id
) then
9933 -- Its possible homonyms are not affected by the pragma.
9934 -- Such homonyms might be present in the context of other
9935 -- units being compiled.
9939 elsif From_Aspect_Specification
(N
) then
9942 -- If the pragma was created by the compiler, then we don't
9943 -- want it to apply to other homonyms. This kind of case can
9944 -- occur when using pragma Provide_Shift_Operators, which
9945 -- generates implicit shift and rotate operators with Import
9946 -- pragmas that might apply to earlier explicit or implicit
9947 -- declarations marked with Import (for example, coming from
9948 -- an earlier pragma Provide_Shift_Operators for another type),
9949 -- and we don't generally want other homonyms being treated
9950 -- as imported or the pragma flagged as an illegal duplicate.
9952 elsif not Comes_From_Source
(N
) then
9956 Hom_Id
:= Homonym
(Hom_Id
);
9960 -- Import a CPP class
9962 elsif C
= Convention_CPP
9963 and then (Is_Record_Type
(Def_Id
)
9964 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9966 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9967 if Present
(Full_View
(Def_Id
)) then
9968 Def_Id
:= Full_View
(Def_Id
);
9972 ("cannot import 'C'P'P type before full declaration seen",
9973 Get_Pragma_Arg
(Arg2
));
9975 -- Although we have reported the error we decorate it as
9976 -- CPP_Class to avoid reporting spurious errors
9978 Set_Is_CPP_Class
(Def_Id
);
9983 -- Types treated as CPP classes must be declared limited (note:
9984 -- this used to be a warning but there is no real benefit to it
9985 -- since we did effectively intend to treat the type as limited
9988 if not Is_Limited_Type
(Def_Id
) then
9990 ("imported 'C'P'P type must be limited",
9991 Get_Pragma_Arg
(Arg2
));
9994 if Etype
(Def_Id
) /= Def_Id
9995 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9997 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
10000 Set_Is_CPP_Class
(Def_Id
);
10002 -- Imported CPP types must not have discriminants (because C++
10003 -- classes do not have discriminants).
10005 if Has_Discriminants
(Def_Id
) then
10007 ("imported 'C'P'P type cannot have discriminants",
10008 First
(Discriminant_Specifications
10009 (Declaration_Node
(Def_Id
))));
10012 -- Check that components of imported CPP types do not have default
10013 -- expressions. For private types this check is performed when the
10014 -- full view is analyzed (see Process_Full_View).
10016 if not Is_Private_Type
(Def_Id
) then
10017 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
10020 -- Import a CPP exception
10022 elsif C
= Convention_CPP
10023 and then Ekind
(Def_Id
) = E_Exception
10027 ("'External_'Name arguments is required for 'Cpp exception",
10030 -- As only a string is allowed, Check_Arg_Is_External_Name
10033 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
10036 if Present
(Arg4
) then
10038 ("Link_Name argument not allowed for imported Cpp exception",
10042 -- Do not call Set_Interface_Name as the name of the exception
10043 -- shouldn't be modified (and in particular it shouldn't be
10044 -- the External_Name). For exceptions, the External_Name is the
10045 -- name of the RTTI structure.
10047 -- ??? Emit an error if pragma Import/Export_Exception is present
10049 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
10050 Check_No_Link_Name
;
10051 Check_Arg_Count
(3);
10052 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
10054 Process_Import_Predefined_Type
;
10056 -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada
10057 -- compilers may accept more cases, e.g. JGNAT allowed importing
10060 elsif not Relaxed_RM_Semantics
then
10061 if From_Aspect_Specification
(N
) then
10063 ("entity for aspect% must be object, subprogram "
10064 & "or incomplete type",
10068 ("second argument of pragma% must be object, subprogram "
10069 & "or incomplete type",
10074 -- If this pragma applies to a compilation unit, then the unit, which
10075 -- is a subprogram, does not require (or allow) a body. We also do
10076 -- not need to elaborate imported procedures.
10078 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
10080 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
10082 Set_Body_Required
(Cunit
, False);
10085 end Process_Import_Or_Interface
;
10087 --------------------
10088 -- Process_Inline --
10089 --------------------
10091 procedure Process_Inline
(Status
: Inline_Status
) is
10098 Ghost_Error_Posted
: Boolean := False;
10099 -- Flag set when an error concerning the illegal mix of Ghost and
10100 -- non-Ghost subprograms is emitted.
10102 Ghost_Id
: Entity_Id
:= Empty
;
10103 -- The entity of the first Ghost subprogram encountered while
10104 -- processing the arguments of the pragma.
10106 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
10107 -- Verify the placement of pragma Inline_Always with respect to the
10108 -- initial declaration of subprogram Spec_Id.
10110 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
10111 -- Returns True if it can be determined at this stage that inlining
10112 -- is not possible, for example if the body is available and contains
10113 -- exception handlers, we prevent inlining, since otherwise we can
10114 -- get undefined symbols at link time. This function also emits a
10115 -- warning if the pragma appears too late.
10117 -- ??? is business with link symbols still valid, or does it relate
10118 -- to front end ZCX which is being phased out ???
10120 procedure Make_Inline
(Subp
: Entity_Id
);
10121 -- Subp is the defining unit name of the subprogram declaration. If
10122 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
10123 -- the corresponding body, if there is one present.
10125 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
10126 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
10127 -- Also set or clear Is_Inlined flag on Subp depending on Status.
10129 -----------------------------------
10130 -- Check_Inline_Always_Placement --
10131 -----------------------------------
10133 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
10134 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
10136 function Compilation_Unit_OK
return Boolean;
10137 pragma Inline
(Compilation_Unit_OK
);
10138 -- Determine whether pragma Inline_Always applies to a compatible
10139 -- compilation unit denoted by Spec_Id.
10141 function Declarative_List_OK
return Boolean;
10142 pragma Inline
(Declarative_List_OK
);
10143 -- Determine whether the initial declaration of subprogram Spec_Id
10144 -- and the pragma appear in compatible declarative lists.
10146 function Subprogram_Body_OK
return Boolean;
10147 pragma Inline
(Subprogram_Body_OK
);
10148 -- Determine whether pragma Inline_Always applies to a compatible
10149 -- subprogram body denoted by Spec_Id.
10151 -------------------------
10152 -- Compilation_Unit_OK --
10153 -------------------------
10155 function Compilation_Unit_OK
return Boolean is
10156 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
10159 -- The pragma appears after the initial declaration of a
10160 -- compilation unit.
10162 -- procedure Comp_Unit;
10163 -- pragma Inline_Always (Comp_Unit);
10165 -- Note that for compatibility reasons, the following case is
10168 -- procedure Stand_Alone_Body_Comp_Unit is
10170 -- end Stand_Alone_Body_Comp_Unit;
10171 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
10174 Nkind
(Comp_Unit
) = N_Compilation_Unit
10175 and then Present
(Aux_Decls_Node
(Comp_Unit
))
10176 and then Is_List_Member
(N
)
10177 and then List_Containing
(N
) =
10178 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
10179 end Compilation_Unit_OK
;
10181 -------------------------
10182 -- Declarative_List_OK --
10183 -------------------------
10185 function Declarative_List_OK
return Boolean is
10186 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
10188 Init_Decl
: Node_Id
;
10189 Init_List
: List_Id
;
10190 Prag_List
: List_Id
;
10193 -- Determine the proper initial declaration. In general this is
10194 -- the declaration node of the subprogram except when the input
10195 -- denotes a generic instantiation.
10197 -- procedure Inst is new Gen;
10198 -- pragma Inline_Always (Inst);
10200 -- In this case the original subprogram is moved inside an
10201 -- anonymous package while pragma Inline_Always remains at the
10202 -- level of the anonymous package. Use the declaration of the
10203 -- package because it reflects the placement of the original
10206 -- package Anon_Pack is
10207 -- procedure Inst is ... end Inst; -- original
10210 -- procedure Inst renames Anon_Pack.Inst;
10211 -- pragma Inline_Always (Inst);
10213 if Is_Generic_Instance
(Spec_Id
) then
10214 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
10215 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
10217 Init_Decl
:= Spec_Decl
;
10220 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
10221 Init_List
:= List_Containing
(Init_Decl
);
10222 Prag_List
:= List_Containing
(N
);
10224 -- The pragma and then initial declaration appear within the
10225 -- same declarative list.
10227 if Init_List
= Prag_List
then
10230 -- A special case of the above is when both the pragma and
10231 -- the initial declaration appear in different lists of a
10232 -- package spec, protected definition, or a task definition.
10237 -- pragma Inline_Always (Proc);
10240 elsif Nkind
(Context
) in N_Package_Specification
10241 | N_Protected_Definition
10242 | N_Task_Definition
10243 and then Init_List
= Visible_Declarations
(Context
)
10244 and then Prag_List
= Private_Declarations
(Context
)
10251 end Declarative_List_OK
;
10253 ------------------------
10254 -- Subprogram_Body_OK --
10255 ------------------------
10257 function Subprogram_Body_OK
return Boolean is
10258 Body_Decl
: Node_Id
;
10261 -- The pragma appears within the declarative list of a stand-
10262 -- alone subprogram body.
10264 -- procedure Stand_Alone_Body is
10265 -- pragma Inline_Always (Stand_Alone_Body);
10268 -- end Stand_Alone_Body;
10270 -- The compiler creates a dummy spec in this case, however the
10271 -- pragma remains within the declarative list of the body.
10273 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
10274 and then not Comes_From_Source
(Spec_Decl
)
10275 and then Present
(Corresponding_Body
(Spec_Decl
))
10278 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
10280 if Present
(Declarations
(Body_Decl
))
10281 and then Is_List_Member
(N
)
10282 and then List_Containing
(N
) = Declarations
(Body_Decl
)
10289 end Subprogram_Body_OK
;
10291 -- Start of processing for Check_Inline_Always_Placement
10294 -- This check is relevant only for pragma Inline_Always
10296 if Pname
/= Name_Inline_Always
then
10299 -- Nothing to do when the pragma is internally generated on the
10300 -- assumption that it is properly placed.
10302 elsif not Comes_From_Source
(N
) then
10305 -- Nothing to do for internally generated subprograms that act
10306 -- as accidental homonyms of a source subprogram being inlined.
10308 elsif not Comes_From_Source
(Spec_Id
) then
10311 -- Nothing to do for generic formal subprograms that act as
10312 -- homonyms of another source subprogram being inlined.
10314 elsif Is_Formal_Subprogram
(Spec_Id
) then
10317 elsif Compilation_Unit_OK
10318 or else Declarative_List_OK
10319 or else Subprogram_Body_OK
10324 -- At this point it is known that the pragma applies to or appears
10325 -- within a completing body, a completing stub, or a subunit.
10327 Error_Msg_Name_1
:= Pname
;
10328 Error_Msg_Name_2
:= Chars
(Spec_Id
);
10329 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
10332 ("pragma % must appear on initial declaration of subprogram "
10333 & "% defined #", N
);
10334 end Check_Inline_Always_Placement
;
10336 ---------------------------
10337 -- Inlining_Not_Possible --
10338 ---------------------------
10340 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
10341 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
10345 if Nkind
(Decl
) = N_Subprogram_Body
then
10346 Stats
:= Handled_Statement_Sequence
(Decl
);
10347 return Present
(Exception_Handlers
(Stats
))
10348 or else Present
(At_End_Proc
(Stats
));
10350 elsif Nkind
(Decl
) = N_Subprogram_Declaration
10351 and then Present
(Corresponding_Body
(Decl
))
10353 if Analyzed
(Corresponding_Body
(Decl
)) then
10354 Error_Msg_N
("pragma appears too late, ignored??", N
);
10357 -- If the subprogram is a renaming as body, the body is just a
10358 -- call to the renamed subprogram, and inlining is trivially
10362 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
10363 N_Subprogram_Renaming_Declaration
10369 Handled_Statement_Sequence
10370 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
10373 Present
(Exception_Handlers
(Stats
))
10374 or else Present
(At_End_Proc
(Stats
));
10378 -- If body is not available, assume the best, the check is
10379 -- performed again when compiling enclosing package bodies.
10383 end Inlining_Not_Possible
;
10389 procedure Make_Inline
(Subp
: Entity_Id
) is
10390 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
10391 Inner_Subp
: Entity_Id
:= Subp
;
10394 -- Ignore if bad type, avoid cascaded error
10396 if Etype
(Subp
) = Any_Type
then
10400 -- If inlining is not possible, for now do not treat as an error
10402 elsif Status
/= Suppressed
10403 and then Front_End_Inlining
10404 and then Inlining_Not_Possible
(Subp
)
10409 -- Here we have a candidate for inlining, but we must exclude
10410 -- derived operations. Otherwise we would end up trying to inline
10411 -- a phantom declaration, and the result would be to drag in a
10412 -- body which has no direct inlining associated with it. That
10413 -- would not only be inefficient but would also result in the
10414 -- backend doing cross-unit inlining in cases where it was
10415 -- definitely inappropriate to do so.
10417 -- However, a simple Comes_From_Source test is insufficient, since
10418 -- we do want to allow inlining of generic instances which also do
10419 -- not come from source. We also need to recognize specs generated
10420 -- by the front-end for bodies that carry the pragma. Finally,
10421 -- predefined operators do not come from source but are not
10422 -- inlineable either.
10424 elsif Is_Generic_Instance
(Subp
)
10425 or else Parent_Kind
(Parent
(Subp
)) = N_Subprogram_Declaration
10429 elsif not Comes_From_Source
(Subp
)
10430 and then Scope
(Subp
) /= Standard_Standard
10436 -- The referenced entity must either be the enclosing entity, or
10437 -- an entity declared within the current open scope.
10439 if Present
(Scope
(Subp
))
10440 and then Scope
(Subp
) /= Current_Scope
10441 and then Subp
/= Current_Scope
10444 ("argument of% must be entity in current scope", Assoc
);
10447 -- Processing for procedure, operator or function. If subprogram
10448 -- is aliased (as for an instance) indicate that the renamed
10449 -- entity (if declared in the same unit) is inlined.
10450 -- If this is the anonymous subprogram created for a subprogram
10451 -- instance, the inlining applies to it directly. Otherwise we
10452 -- retrieve it as the alias of the visible subprogram instance.
10454 if Is_Subprogram
(Subp
) then
10456 -- Ensure that pragma Inline_Always is associated with the
10457 -- initial declaration of the subprogram.
10459 Check_Inline_Always_Placement
(Subp
);
10461 if Is_Wrapper_Package
(Scope
(Subp
)) then
10462 Inner_Subp
:= Subp
;
10464 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
10467 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
10468 Set_Inline_Flags
(Inner_Subp
);
10470 if Present
(Parent
(Inner_Subp
)) then
10471 Decl
:= Parent
(Parent
(Inner_Subp
));
10476 if Nkind
(Decl
) = N_Subprogram_Declaration
10477 and then Present
(Corresponding_Body
(Decl
))
10479 Set_Inline_Flags
(Corresponding_Body
(Decl
));
10481 elsif Is_Generic_Instance
(Subp
)
10482 and then Comes_From_Source
(Subp
)
10484 -- Indicate that the body needs to be created for
10485 -- inlining subsequent calls. The instantiation node
10486 -- follows the declaration of the wrapper package
10487 -- created for it. The subprogram that requires the
10488 -- body is the anonymous one in the wrapper package.
10490 if Scope
(Subp
) /= Standard_Standard
10492 Need_Subprogram_Instance_Body
10493 (Next
(Unit_Declaration_Node
10494 (Scope
(Alias
(Subp
)))), Subp
)
10499 -- Inline is a program unit pragma (RM 10.1.5) and cannot
10500 -- appear in a formal part to apply to a formal subprogram.
10501 -- Do not apply check within an instance or a formal package
10502 -- the test will have been applied to the original generic.
10504 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
10505 and then In_Same_List
(Decl
, N
)
10506 and then not In_Instance
10509 ("Inline cannot apply to a formal subprogram", N
);
10515 -- For a generic subprogram set flag as well, for use at the point
10516 -- of instantiation, to determine whether the body should be
10519 elsif Is_Generic_Subprogram
(Subp
) then
10520 Set_Inline_Flags
(Subp
);
10523 -- Literals are by definition inlined
10525 elsif Kind
= E_Enumeration_Literal
then
10528 -- Anything else is an error
10532 ("expect subprogram name for pragma%", Assoc
);
10536 ----------------------
10537 -- Set_Inline_Flags --
10538 ----------------------
10540 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
10542 -- First set the Has_Pragma_XXX flags and issue the appropriate
10543 -- errors and warnings for suspicious combinations.
10545 if Prag_Id
= Pragma_No_Inline
then
10546 if Has_Pragma_Inline_Always
(Subp
) then
10548 ("Inline_Always and No_Inline are mutually exclusive", N
);
10549 elsif Has_Pragma_Inline
(Subp
) then
10551 ("Inline and No_Inline both specified for& ??",
10552 N
, Entity
(Subp_Id
));
10555 Set_Has_Pragma_No_Inline
(Subp
);
10557 if Prag_Id
= Pragma_Inline_Always
then
10558 if Has_Pragma_No_Inline
(Subp
) then
10560 ("Inline_Always and No_Inline are mutually exclusive",
10564 Set_Has_Pragma_Inline_Always
(Subp
);
10566 if Has_Pragma_No_Inline
(Subp
) then
10568 ("Inline and No_Inline both specified for& ??",
10569 N
, Entity
(Subp_Id
));
10573 Set_Has_Pragma_Inline
(Subp
);
10576 -- Then adjust the Is_Inlined flag. It can never be set if the
10577 -- subprogram is subject to pragma No_Inline.
10581 Set_Is_Inlined
(Subp
, False);
10587 if not Has_Pragma_No_Inline
(Subp
) then
10588 Set_Is_Inlined
(Subp
, True);
10592 -- A pragma that applies to a Ghost entity becomes Ghost for the
10593 -- purposes of legality checks and removal of ignored Ghost code.
10595 Mark_Ghost_Pragma
(N
, Subp
);
10597 -- Capture the entity of the first Ghost subprogram being
10598 -- processed for error detection purposes.
10600 if Is_Ghost_Entity
(Subp
) then
10601 if No
(Ghost_Id
) then
10605 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10606 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10608 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
10609 Ghost_Error_Posted
:= True;
10611 Error_Msg_Name_1
:= Pname
;
10613 ("pragma % cannot mention ghost and non-ghost subprograms",
10616 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
10617 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
10619 Error_Msg_Sloc
:= Sloc
(Subp
);
10620 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
10622 end Set_Inline_Flags
;
10624 -- Start of processing for Process_Inline
10627 -- An inlined subprogram may grant access to its private enclosing
10628 -- context depending on the placement of its body. From elaboration
10629 -- point of view, the flow of execution may enter this private
10630 -- context, and then reach an external unit, thus producing a
10631 -- dependency on that external unit. For such a path to be properly
10632 -- discovered and encoded in the ALI file of the main unit, let the
10633 -- ABE mechanism process the body of the main unit, and encode all
10634 -- relevant invocation constructs and the relations between them.
10636 Mark_Save_Invocation_Graph_Of_Body
;
10638 Check_No_Identifiers
;
10639 Check_At_Least_N_Arguments
(1);
10641 if Status
= Enabled
then
10642 Inline_Processing_Required
:= True;
10646 while Present
(Assoc
) loop
10647 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
10651 if Is_Entity_Name
(Subp_Id
) then
10652 Subp
:= Entity
(Subp_Id
);
10654 if Subp
= Any_Id
then
10656 -- If previous error, avoid cascaded errors
10658 Check_Error_Detected
;
10662 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10663 -- is given that directly specifies an aspect of an entity,
10664 -- then it is illegal to give another [...]
10665 -- aspect_specification that directly specifies the same
10666 -- aspect of the entity.
10667 -- We only check Subp directly as per "directly specifies"
10668 -- above and because the case of pragma Inline is really
10669 -- special given its pre aspect usage.
10671 Check_Duplicate_Pragma
(Subp
);
10672 Record_Rep_Item
(Subp
, N
);
10674 Make_Inline
(Subp
);
10676 -- For the pragma case, climb homonym chain. This is
10677 -- what implements allowing the pragma in the renaming
10678 -- case, with the result applying to the ancestors, and
10679 -- also allows Inline to apply to all previous homonyms.
10681 if not From_Aspect_Specification
(N
) then
10682 while Present
(Homonym
(Subp
))
10683 and then Scope
(Homonym
(Subp
)) = Current_Scope
10685 Subp
:= Homonym
(Subp
);
10686 Make_Inline
(Subp
);
10692 if not Applies
then
10693 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
10699 -- If the context is a package declaration, the pragma indicates
10700 -- that inlining will require the presence of the corresponding
10701 -- body. (this may be further refined).
10704 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
10705 N_Package_Declaration
10707 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
10709 end Process_Inline
;
10711 ----------------------------
10712 -- Process_Interface_Name --
10713 ----------------------------
10715 procedure Process_Interface_Name
10716 (Subprogram_Def
: Entity_Id
;
10718 Link_Arg
: Node_Id
;
10722 Link_Nam
: Node_Id
;
10723 String_Val
: String_Id
;
10725 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
10726 -- SN is a string literal node for an interface name. This routine
10727 -- performs some minimal checks that the name is reasonable. In
10728 -- particular that no spaces or other obviously incorrect characters
10729 -- appear. This is only a warning, since any characters are allowed.
10731 ----------------------------------
10732 -- Check_Form_Of_Interface_Name --
10733 ----------------------------------
10735 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
10736 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
10737 SL
: constant Nat
:= String_Length
(S
);
10742 Error_Msg_N
("interface name cannot be null string", SN
);
10745 for J
in 1 .. SL
loop
10746 C
:= Get_String_Char
(S
, J
);
10748 -- Look for dubious character and issue unconditional warning.
10749 -- Definitely dubious if not in character range.
10751 if not In_Character_Range
(C
)
10753 -- Commas, spaces and (back)slashes are dubious
10755 or else Get_Character
(C
) = ','
10756 or else Get_Character
(C
) = '\'
10757 or else Get_Character
(C
) = ' '
10758 or else Get_Character
(C
) = '/'
10761 ("??interface name contains illegal character",
10762 Sloc
(SN
) + Source_Ptr
(J
));
10765 end Check_Form_Of_Interface_Name
;
10767 -- Start of processing for Process_Interface_Name
10770 -- If we are looking at a pragma that comes from an aspect then it
10771 -- needs to have its corresponding aspect argument expressions
10772 -- analyzed in addition to the generated pragma so that aspects
10773 -- within generic units get properly resolved.
10775 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
10777 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
10785 -- Obtain all interfacing aspects used to construct the pragma
10787 Get_Interfacing_Aspects
10788 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
10790 -- Analyze the expression of aspect External_Name
10792 if Present
(EN
) then
10793 Analyze
(Expression
(EN
));
10796 -- Analyze the expressio of aspect Link_Name
10798 if Present
(LN
) then
10799 Analyze
(Expression
(LN
));
10804 if No
(Link_Arg
) then
10805 if No
(Ext_Arg
) then
10808 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10810 Link_Nam
:= Expression
(Ext_Arg
);
10813 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10814 Ext_Nam
:= Expression
(Ext_Arg
);
10819 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10820 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10821 Ext_Nam
:= Expression
(Ext_Arg
);
10822 Link_Nam
:= Expression
(Link_Arg
);
10825 -- Check expressions for external name and link name are static
10827 if Present
(Ext_Nam
) then
10828 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10829 Check_Form_Of_Interface_Name
(Ext_Nam
);
10831 -- Verify that external name is not the name of a local entity,
10832 -- which would hide the imported one and could lead to run-time
10833 -- surprises. The problem can only arise for entities declared in
10834 -- a package body (otherwise the external name is fully qualified
10835 -- and will not conflict).
10843 if Prag_Id
= Pragma_Import
then
10844 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10845 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10847 if Nam
/= Chars
(Subprogram_Def
)
10848 and then Present
(E
)
10849 and then not Is_Overloadable
(E
)
10850 and then Is_Immediately_Visible
(E
)
10851 and then not Is_Imported
(E
)
10852 and then Ekind
(Scope
(E
)) = E_Package
10855 while Present
(Par
) loop
10856 if Nkind
(Par
) = N_Package_Body
then
10857 Error_Msg_Sloc
:= Sloc
(E
);
10859 ("imported entity is hidden by & declared#",
10864 Par
:= Parent
(Par
);
10871 if Present
(Link_Nam
) then
10872 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10873 Check_Form_Of_Interface_Name
(Link_Nam
);
10876 -- If there is no link name, just set the external name
10878 if No
(Link_Nam
) then
10879 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10881 -- For the Link_Name case, the given literal is preceded by an
10882 -- asterisk, which indicates to GCC that the given name should be
10883 -- taken literally, and in particular that no prepending of
10884 -- underlines should occur, even in systems where this is the
10889 Store_String_Char
(Get_Char_Code
('*'));
10890 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10891 Store_String_Chars
(String_Val
);
10893 Make_String_Literal
(Sloc
(Link_Nam
),
10894 Strval
=> End_String
);
10897 -- Set the interface name. If the entity is a generic instance, use
10898 -- its alias, which is the callable entity.
10900 if Is_Generic_Instance
(Subprogram_Def
) then
10901 Set_Encoded_Interface_Name
10902 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10904 Set_Encoded_Interface_Name
10905 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10908 Check_Duplicated_Export_Name
(Link_Nam
);
10909 end Process_Interface_Name
;
10911 -----------------------------------------
10912 -- Process_Interrupt_Or_Attach_Handler --
10913 -----------------------------------------
10915 procedure Process_Interrupt_Or_Attach_Handler
is
10916 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10917 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10920 -- A pragma that applies to a Ghost entity becomes Ghost for the
10921 -- purposes of legality checks and removal of ignored Ghost code.
10923 Mark_Ghost_Pragma
(N
, Handler
);
10924 Set_Is_Interrupt_Handler
(Handler
);
10926 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10928 Record_Rep_Item
(Prot_Typ
, N
);
10930 -- Chain the pragma on the contract for completeness
10932 Add_Contract_Item
(N
, Handler
);
10933 end Process_Interrupt_Or_Attach_Handler
;
10935 --------------------------------------------------
10936 -- Process_Restrictions_Or_Restriction_Warnings --
10937 --------------------------------------------------
10939 -- Note: some of the simple identifier cases were handled in par-prag,
10940 -- but it is harmless (and more straightforward) to simply handle all
10941 -- cases here, even if it means we repeat a bit of work in some cases.
10943 procedure Process_Restrictions_Or_Restriction_Warnings
10947 R_Id
: Restriction_Id
;
10952 procedure Process_No_Specification_of_Aspect
;
10953 -- Process the No_Specification_of_Aspect restriction
10955 procedure Process_No_Use_Of_Attribute
;
10956 -- Process the No_Use_Of_Attribute restriction
10958 ----------------------------------------
10959 -- Process_No_Specification_of_Aspect --
10960 ----------------------------------------
10962 procedure Process_No_Specification_of_Aspect
is
10963 Name
: constant Name_Id
:= Chars
(Expr
);
10965 if Nkind
(Expr
) = N_Identifier
10966 and then Is_Aspect_Id
(Name
)
10968 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10970 Bad_Aspect
(Expr
, Name
, Warn
=> True);
10974 end Process_No_Specification_of_Aspect
;
10976 ---------------------------------
10977 -- Process_No_Use_Of_Attribute --
10978 ---------------------------------
10980 procedure Process_No_Use_Of_Attribute
is
10981 Name
: constant Name_Id
:= Chars
(Expr
);
10983 if Nkind
(Expr
) = N_Identifier
10984 and then Is_Attribute_Name
(Name
)
10986 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10988 Bad_Attribute
(Expr
, Name
, Warn
=> True);
10991 end Process_No_Use_Of_Attribute
;
10993 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
10996 -- Ignore all Restrictions pragmas in CodePeer mode
10998 if CodePeer_Mode
then
11002 Check_Ada_83_Warning
;
11003 Check_At_Least_N_Arguments
(1);
11004 Check_Valid_Configuration_Pragma
;
11007 while Present
(Arg
) loop
11009 Expr
:= Get_Pragma_Arg
(Arg
);
11011 -- Case of no restriction identifier present
11013 if Id
= No_Name
then
11014 if Nkind
(Expr
) /= N_Identifier
then
11016 ("invalid form for restriction", Arg
);
11021 (Process_Restriction_Synonyms
(Expr
));
11023 if R_Id
not in All_Boolean_Restrictions
then
11024 Error_Msg_Name_1
:= Pname
;
11026 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
11028 -- Check for possible misspelling
11030 for J
in All_Restrictions
loop
11032 Rnm
: constant String := Restriction_Id
'Image (J
);
11035 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
11036 Name_Len
:= Rnm
'Length;
11037 Set_Casing
(All_Lower_Case
);
11039 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
11042 (Source_Index
(Current_Sem_Unit
)));
11043 Error_Msg_String
(1 .. Rnm
'Length) :=
11044 Name_Buffer
(1 .. Name_Len
);
11045 Error_Msg_Strlen
:= Rnm
'Length;
11046 Error_Msg_N
-- CODEFIX
11047 ("\possible misspelling of ""~""",
11048 Get_Pragma_Arg
(Arg
));
11057 if Implementation_Restriction
(R_Id
) then
11058 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
11061 -- Special processing for No_Elaboration_Code restriction
11063 if R_Id
= No_Elaboration_Code
then
11065 -- Restriction is only recognized within a configuration
11066 -- pragma file, or within a unit of the main extended
11067 -- program. Note: the test for Main_Unit is needed to
11068 -- properly include the case of configuration pragma files.
11070 if not (Current_Sem_Unit
= Main_Unit
11071 or else In_Extended_Main_Source_Unit
(N
))
11075 -- Don't allow in a subunit unless already specified in
11078 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
11079 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
11080 and then not Restriction_Active
(No_Elaboration_Code
)
11083 ("invalid specification of ""No_Elaboration_Code""",
11086 ("\restriction cannot be specified in a subunit", N
);
11088 ("\unless also specified in body or spec", N
);
11091 -- If we accept a No_Elaboration_Code restriction, then it
11092 -- needs to be added to the configuration restriction set so
11093 -- that we get proper application to other units in the main
11094 -- extended source as required.
11097 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
11100 -- Special processing for No_Dynamic_Accessibility_Checks to
11101 -- disallow exclusive specification in a body or subunit.
11103 elsif R_Id
= No_Dynamic_Accessibility_Checks
11104 -- Check if the restriction is within configuration pragma
11105 -- in a similar way to No_Elaboration_Code.
11107 and then not (Current_Sem_Unit
= Main_Unit
11108 or else In_Extended_Main_Source_Unit
(N
))
11110 and then Nkind
(Unit
(Parent
(N
))) = N_Compilation_Unit
11112 and then (Nkind
(Unit
(Parent
(N
))) = N_Package_Body
11113 or else Nkind
(Unit
(Parent
(N
))) = N_Subunit
)
11115 and then not Restriction_Active
11116 (No_Dynamic_Accessibility_Checks
)
11119 ("invalid specification of " &
11120 """No_Dynamic_Accessibility_Checks""", N
);
11122 if Nkind
(Unit
(Parent
(N
))) = N_Package_Body
then
11124 ("\restriction cannot be specified in a package " &
11127 elsif Nkind
(Unit
(Parent
(N
))) = N_Subunit
then
11129 ("\restriction cannot be specified in a subunit", N
);
11133 ("\unless also specified in spec", N
);
11135 -- Special processing for No_Tasking restriction (not just a
11136 -- warning) when it appears as a configuration pragma.
11138 elsif R_Id
= No_Tasking
11139 and then No
(Cunit
(Main_Unit
))
11142 Set_Global_No_Tasking
;
11145 Set_Restriction
(R_Id
, N
, Warn
);
11147 if R_Id
= No_Dynamic_CPU_Assignment
11148 or else R_Id
= No_Tasks_Unassigned_To_CPU
11150 -- These imply No_Dependence =>
11151 -- "System.Multiprocessors.Dispatching_Domains".
11152 -- This is not strictly what the AI says, but it eliminates
11153 -- the need for run-time checks, which are undesirable in
11156 Set_Restriction_No_Dependence
11158 (Sel_Comp
("system", "multiprocessors", Loc
),
11159 "dispatching_domains"),
11163 if R_Id
= No_Tasks_Unassigned_To_CPU
then
11164 -- Likewise, imply No_Dynamic_CPU_Assignment
11166 Set_Restriction
(No_Dynamic_CPU_Assignment
, N
, Warn
);
11169 -- Check for obsolescent restrictions in Ada 2005 mode
11172 and then Ada_Version
>= Ada_2005
11173 and then (R_Id
= No_Asynchronous_Control
11175 R_Id
= No_Unchecked_Deallocation
11177 R_Id
= No_Unchecked_Conversion
)
11179 Check_Restriction
(No_Obsolescent_Features
, N
);
11182 -- A very special case that must be processed here: pragma
11183 -- Restrictions (No_Exceptions) turns off all run-time
11184 -- checking. This is a bit dubious in terms of the formal
11185 -- language definition, but it is what is intended by RM
11186 -- H.4(12). Restriction_Warnings never affects generated code
11187 -- so this is done only in the real restriction case.
11189 -- Atomic_Synchronization is not a real check, so it is not
11190 -- affected by this processing).
11192 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
11193 -- run-time checks in CodePeer and GNATprove modes: we want to
11194 -- generate checks for analysis purposes, as set respectively
11195 -- by -gnatC and -gnatd.F
11198 and then not (CodePeer_Mode
or GNATprove_Mode
)
11199 and then R_Id
= No_Exceptions
11201 for J
in Scope_Suppress
.Suppress
'Range loop
11202 if J
/= Atomic_Synchronization
then
11203 Scope_Suppress
.Suppress
(J
) := True;
11208 -- Case of No_Dependence => unit-name. Note that the parser
11209 -- already made the necessary entry in the No_Dependence table.
11211 elsif Id
= Name_No_Dependence
then
11212 if not OK_No_Dependence_Unit_Name
(Expr
) then
11216 -- Case of No_Specification_Of_Aspect => aspect-identifier
11218 elsif Id
= Name_No_Specification_Of_Aspect
then
11219 Process_No_Specification_of_Aspect
;
11221 -- Case of No_Use_Of_Attribute => attribute-identifier
11223 elsif Id
= Name_No_Use_Of_Attribute
then
11224 Process_No_Use_Of_Attribute
;
11226 -- Case of No_Use_Of_Entity => fully-qualified-name
11228 elsif Id
= Name_No_Use_Of_Entity
then
11230 -- Restriction is only recognized within a configuration
11231 -- pragma file, or within a unit of the main extended
11232 -- program. Note: the test for Main_Unit is needed to
11233 -- properly include the case of configuration pragma files.
11235 if Current_Sem_Unit
= Main_Unit
11236 or else In_Extended_Main_Source_Unit
(N
)
11238 if not OK_No_Dependence_Unit_Name
(Expr
) then
11239 Error_Msg_N
("wrong form for entity name", Expr
);
11241 Set_Restriction_No_Use_Of_Entity
11242 (Expr
, Warn
, No_Profile
);
11246 -- Case of No_Use_Of_Pragma => pragma-identifier
11248 elsif Id
= Name_No_Use_Of_Pragma
then
11249 if Nkind
(Expr
) /= N_Identifier
11250 or else not Is_Pragma_Name
(Chars
(Expr
))
11252 Error_Msg_N
("unknown pragma name??", Expr
);
11254 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
11257 -- All other cases of restriction identifier present
11260 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
11262 if R_Id
not in All_Parameter_Restrictions
then
11264 ("invalid restriction parameter identifier", Arg
);
11267 Analyze_And_Resolve
(Expr
, Any_Integer
);
11269 if not Is_OK_Static_Expression
(Expr
) then
11270 Flag_Non_Static_Expr
11271 ("value must be static expression!", Expr
);
11274 elsif not Is_Integer_Type
(Etype
(Expr
))
11275 or else Expr_Value
(Expr
) < 0
11278 ("value must be non-negative integer", Arg
);
11281 -- Restriction pragma is active
11283 Val
:= Expr_Value
(Expr
);
11285 if not UI_Is_In_Int_Range
(Val
) then
11287 ("pragma ignored, value too large??", Arg
);
11290 Set_Restriction
(R_Id
, N
, Warn
, Integer (UI_To_Int
(Val
)));
11295 end Process_Restrictions_Or_Restriction_Warnings
;
11297 ---------------------------------
11298 -- Process_Suppress_Unsuppress --
11299 ---------------------------------
11301 -- Note: this procedure makes entries in the check suppress data
11302 -- structures managed by Sem. See spec of package Sem for full
11303 -- details on how we handle recording of check suppression.
11305 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
11310 In_Package_Spec
: constant Boolean :=
11311 Is_Package_Or_Generic_Package
(Current_Scope
)
11312 and then not In_Package_Body
(Current_Scope
);
11314 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
11315 -- Used to suppress a single check on the given entity
11317 --------------------------------
11318 -- Suppress_Unsuppress_Echeck --
11319 --------------------------------
11321 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
11323 -- Check for error of trying to set atomic synchronization for
11324 -- a non-atomic variable.
11326 if C
= Atomic_Synchronization
11327 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
11330 ("pragma & requires atomic type or variable",
11331 Pragma_Identifier
(Original_Node
(N
)));
11334 Set_Checks_May_Be_Suppressed
(E
);
11336 if In_Package_Spec
then
11337 Push_Global_Suppress_Stack_Entry
11340 Suppress
=> Suppress_Case
);
11342 Push_Local_Suppress_Stack_Entry
11345 Suppress
=> Suppress_Case
);
11348 -- If this is a first subtype, and the base type is distinct,
11349 -- then also set the suppress flags on the base type.
11351 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
11352 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
11354 end Suppress_Unsuppress_Echeck
;
11356 -- Start of processing for Process_Suppress_Unsuppress
11359 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
11360 -- on user code: we want to generate checks for analysis purposes, as
11361 -- set respectively by -gnatC and -gnatd.F
11363 if Comes_From_Source
(N
)
11364 and then (CodePeer_Mode
or GNATprove_Mode
)
11369 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
11370 -- declarative part or a package spec (RM 11.5(5)).
11372 if not Is_Configuration_Pragma
then
11373 Check_Is_In_Decl_Part_Or_Package_Spec
;
11376 Check_At_Least_N_Arguments
(1);
11377 Check_At_Most_N_Arguments
(2);
11378 Check_No_Identifier
(Arg1
);
11379 Check_Arg_Is_Identifier
(Arg1
);
11381 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
11383 if C
= No_Check_Id
then
11385 ("argument of pragma% is not valid check name", Arg1
);
11388 -- Warn that suppress of Elaboration_Check has no effect in SPARK
11390 if C
= Elaboration_Check
11391 and then Suppress_Case
11392 and then SPARK_Mode
= On
11395 ("Suppress of Elaboration_Check ignored in SPARK??",
11396 "\elaboration checking rules are statically enforced "
11397 & "(SPARK RM 7.7)", Arg1
);
11400 -- One-argument case
11402 if Arg_Count
= 1 then
11404 -- Make an entry in the local scope suppress table. This is the
11405 -- table that directly shows the current value of the scope
11406 -- suppress check for any check id value.
11408 if C
= All_Checks
then
11410 -- For All_Checks, we set all specific predefined checks with
11411 -- the exception of Elaboration_Check, which is handled
11412 -- specially because of not wanting All_Checks to have the
11413 -- effect of deactivating static elaboration order processing.
11414 -- Atomic_Synchronization is also not affected, since this is
11415 -- not a real check.
11417 for J
in Scope_Suppress
.Suppress
'Range loop
11418 if J
/= Elaboration_Check
11420 J
/= Atomic_Synchronization
11422 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
11426 -- If not All_Checks, and predefined check, then set appropriate
11427 -- scope entry. Note that we will set Elaboration_Check if this
11428 -- is explicitly specified. Atomic_Synchronization is allowed
11429 -- only if internally generated and entity is atomic.
11431 elsif C
in Predefined_Check_Id
11432 and then (not Comes_From_Source
(N
)
11433 or else C
/= Atomic_Synchronization
)
11435 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
11438 -- Also push an entry in the local suppress stack
11440 Push_Local_Suppress_Stack_Entry
11443 Suppress
=> Suppress_Case
);
11445 -- Case of two arguments present, where the check is suppressed for
11446 -- a specified entity (given as the second argument of the pragma)
11449 -- This is obsolescent in Ada 2005 mode
11451 if Ada_Version
>= Ada_2005
then
11452 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
11455 Check_Optional_Identifier
(Arg2
, Name_On
);
11456 E_Id
:= Get_Pragma_Arg
(Arg2
);
11459 if not Is_Entity_Name
(E_Id
) then
11461 ("second argument of pragma% must be entity name", Arg2
);
11464 E
:= Entity
(E_Id
);
11470 -- A pragma that applies to a Ghost entity becomes Ghost for the
11471 -- purposes of legality checks and removal of ignored Ghost code.
11473 Mark_Ghost_Pragma
(N
, E
);
11475 -- Enforce RM 11.5(7) which requires that for a pragma that
11476 -- appears within a package spec, the named entity must be
11477 -- within the package spec. We allow the package name itself
11478 -- to be mentioned since that makes sense, although it is not
11479 -- strictly allowed by 11.5(7).
11482 and then E
/= Current_Scope
11483 and then Scope
(E
) /= Current_Scope
11486 ("entity in pragma% is not in package spec (RM 11.5(7))",
11490 -- Loop through homonyms. As noted below, in the case of a package
11491 -- spec, only homonyms within the package spec are considered.
11494 Suppress_Unsuppress_Echeck
(E
, C
);
11496 if Is_Generic_Instance
(E
)
11497 and then Is_Subprogram
(E
)
11498 and then Present
(Alias
(E
))
11500 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
11503 -- Move to next homonym if not aspect spec case
11505 exit when From_Aspect_Specification
(N
);
11509 -- If we are within a package specification, the pragma only
11510 -- applies to homonyms in the same scope.
11512 exit when In_Package_Spec
11513 and then Scope
(E
) /= Current_Scope
;
11516 end Process_Suppress_Unsuppress
;
11518 -------------------------------
11519 -- Record_Independence_Check --
11520 -------------------------------
11522 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
11523 pragma Unreferenced
(N
, E
);
11525 -- For GCC back ends the validation is done a priori. This code is
11526 -- dead, but might be useful in the future.
11528 -- if not AAMP_On_Target then
11532 -- Independence_Checks.Append ((N, E));
11535 end Record_Independence_Check
;
11541 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
11543 if Is_Imported
(E
) then
11545 ("cannot export entity& that was previously imported", Arg
);
11547 elsif Present
(Address_Clause
(E
))
11548 and then not Relaxed_RM_Semantics
11551 ("cannot export entity& that has an address clause", Arg
);
11554 Set_Is_Exported
(E
);
11556 -- Generate a reference for entity explicitly, because the
11557 -- identifier may be overloaded and name resolution will not
11560 Generate_Reference
(E
, Arg
);
11562 -- Deal with exporting non-library level entity
11564 if not Is_Library_Level_Entity
(E
) then
11566 -- Not allowed at all for subprograms
11568 if Is_Subprogram
(E
) then
11569 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
11571 -- Otherwise set public and statically allocated
11575 Set_Is_Statically_Allocated
(E
);
11577 -- Warn if the corresponding W flag is set
11579 if Warn_On_Export_Import
11581 -- Only do this for something that was in the source. Not
11582 -- clear if this can be False now (there used for sure to be
11583 -- cases on some systems where it was False), but anyway the
11584 -- test is harmless if not needed, so it is retained.
11586 and then Comes_From_Source
(Arg
)
11589 ("?x?& has been made static as a result of Export",
11592 ("\?x?this usage is non-standard and non-portable",
11598 if Warn_On_Export_Import
and Inside_A_Generic
then
11600 ("all instances of& will have the same external name?x?",
11605 ----------------------------------------------
11606 -- Set_Extended_Import_Export_External_Name --
11607 ----------------------------------------------
11609 procedure Set_Extended_Import_Export_External_Name
11610 (Internal_Ent
: Entity_Id
;
11611 Arg_External
: Node_Id
)
11613 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
11614 New_Name
: Node_Id
;
11617 if No
(Arg_External
) then
11621 Check_Arg_Is_External_Name
(Arg_External
);
11623 if Nkind
(Arg_External
) = N_String_Literal
then
11624 if String_Length
(Strval
(Arg_External
)) = 0 then
11627 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
11630 elsif Nkind
(Arg_External
) = N_Identifier
then
11631 New_Name
:= Get_Default_External_Name
(Arg_External
);
11633 -- Check_Arg_Is_External_Name should let through only identifiers and
11634 -- string literals or static string expressions (which are folded to
11635 -- string literals).
11638 raise Program_Error
;
11641 -- If we already have an external name set (by a prior normal Import
11642 -- or Export pragma), then the external names must match
11644 if Present
(Interface_Name
(Internal_Ent
)) then
11646 -- Ignore mismatching names in CodePeer mode, to support some
11647 -- old compilers which would export the same procedure under
11648 -- different names, e.g:
11650 -- pragma Export_Procedure (P, "a");
11651 -- pragma Export_Procedure (P, "b");
11653 if CodePeer_Mode
then
11657 Check_Matching_Internal_Names
: declare
11658 S1
: constant String_Id
:= Strval
(Old_Name
);
11659 S2
: constant String_Id
:= Strval
(New_Name
);
11661 procedure Mismatch
;
11662 pragma No_Return
(Mismatch
);
11663 -- Called if names do not match
11669 procedure Mismatch
is
11671 Error_Msg_Sloc
:= Sloc
(Old_Name
);
11673 ("external name does not match that given #",
11677 -- Start of processing for Check_Matching_Internal_Names
11680 if String_Length
(S1
) /= String_Length
(S2
) then
11684 for J
in 1 .. String_Length
(S1
) loop
11685 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
11690 end Check_Matching_Internal_Names
;
11692 -- Otherwise set the given name
11695 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
11696 Check_Duplicated_Export_Name
(New_Name
);
11698 end Set_Extended_Import_Export_External_Name
;
11704 procedure Set_Imported
(E
: Entity_Id
) is
11706 -- Error message if already imported or exported
11708 if Is_Exported
(E
) or else Is_Imported
(E
) then
11710 -- Error if being set Exported twice
11712 if Is_Exported
(E
) then
11713 Error_Msg_NE
("entity& was previously exported", N
, E
);
11715 -- Ignore error in CodePeer mode where we treat all imported
11716 -- subprograms as unknown.
11718 elsif CodePeer_Mode
then
11721 -- OK if Import/Interface case
11723 elsif Import_Interface_Present
(N
) then
11726 -- Error if being set Imported twice
11729 Error_Msg_NE
("entity& was previously imported", N
, E
);
11732 Error_Msg_Name_1
:= Pname
;
11734 ("\(pragma% applies to all previous entities)", N
);
11736 Error_Msg_Sloc
:= Sloc
(E
);
11737 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
11739 -- Here if not previously imported or exported, OK to import
11742 Set_Is_Imported
(E
);
11744 -- For subprogram, set Import_Pragma field
11746 if Is_Subprogram
(E
) then
11747 Set_Import_Pragma
(E
, N
);
11750 -- If the entity is an object that is not at the library level,
11751 -- then it is statically allocated. We do not worry about objects
11752 -- with address clauses in this context since they are not really
11753 -- imported in the linker sense.
11756 and then not Is_Library_Level_Entity
(E
)
11757 and then No
(Address_Clause
(E
))
11759 Set_Is_Statically_Allocated
(E
);
11766 -------------------------
11767 -- Set_Mechanism_Value --
11768 -------------------------
11770 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11771 -- analyzed, since it is semantic nonsense), so we get it in the exact
11772 -- form created by the parser.
11774 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
11775 procedure Bad_Mechanism
;
11776 pragma No_Return
(Bad_Mechanism
);
11777 -- Signal bad mechanism name
11779 -------------------
11780 -- Bad_Mechanism --
11781 -------------------
11783 procedure Bad_Mechanism
is
11785 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
11788 -- Start of processing for Set_Mechanism_Value
11791 if Mechanism
(Ent
) /= Default_Mechanism
then
11793 ("mechanism for & has already been set", Mech_Name
, Ent
);
11796 -- MECHANISM_NAME ::= value | reference
11798 if Nkind
(Mech_Name
) = N_Identifier
then
11799 if Chars
(Mech_Name
) = Name_Value
then
11800 Set_Mechanism
(Ent
, By_Copy
);
11803 elsif Chars
(Mech_Name
) = Name_Reference
then
11804 Set_Mechanism
(Ent
, By_Reference
);
11807 elsif Chars
(Mech_Name
) = Name_Copy
then
11809 ("bad mechanism name, Value assumed", Mech_Name
);
11818 end Set_Mechanism_Value
;
11820 --------------------------
11821 -- Set_Rational_Profile --
11822 --------------------------
11824 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11825 -- extension to the semantics of renaming declarations.
11827 procedure Set_Rational_Profile
is
11829 Implicit_Packing
:= True;
11830 Overriding_Renamings
:= True;
11831 Use_VADS_Size
:= True;
11832 end Set_Rational_Profile
;
11834 ---------------------------
11835 -- Set_Ravenscar_Profile --
11836 ---------------------------
11838 -- The tasks to be done here are
11840 -- Set required policies
11842 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11843 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11844 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11845 -- (For GNAT_Ravenscar_EDF profile)
11846 -- pragma Locking_Policy (Ceiling_Locking)
11848 -- Set Detect_Blocking mode
11850 -- Set required restrictions (see System.Rident for detailed list)
11852 -- Set the No_Dependence rules
11853 -- No_Dependence => Ada.Asynchronous_Task_Control
11854 -- No_Dependence => Ada.Calendar
11855 -- No_Dependence => Ada.Execution_Time.Group_Budget
11856 -- No_Dependence => Ada.Execution_Time.Timers
11857 -- No_Dependence => Ada.Task_Attributes
11858 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11860 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11861 procedure Set_Error_Msg_To_Profile_Name
;
11862 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11865 -----------------------------------
11866 -- Set_Error_Msg_To_Profile_Name --
11867 -----------------------------------
11869 procedure Set_Error_Msg_To_Profile_Name
is
11870 Prof_Nam
: constant Node_Id
:=
11872 (First
(Pragma_Argument_Associations
(N
)));
11875 Get_Name_String
(Chars
(Prof_Nam
));
11876 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11877 Error_Msg_Strlen
:= Name_Len
;
11878 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11879 end Set_Error_Msg_To_Profile_Name
;
11881 Profile_Dispatching_Policy
: Character;
11883 -- Start of processing for Set_Ravenscar_Profile
11886 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11888 if Profile
= GNAT_Ravenscar_EDF
then
11889 Profile_Dispatching_Policy
:= 'E';
11891 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11894 Profile_Dispatching_Policy
:= 'F';
11897 if Task_Dispatching_Policy
/= ' '
11898 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11900 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11901 Set_Error_Msg_To_Profile_Name
;
11902 Error_Pragma
("Profile (~) incompatible with policy#");
11904 -- Set the FIFO_Within_Priorities policy, but always preserve
11905 -- System_Location since we like the error message with the run time
11909 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11911 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11912 Task_Dispatching_Policy_Sloc
:= Loc
;
11916 -- pragma Locking_Policy (Ceiling_Locking)
11918 if Locking_Policy
/= ' '
11919 and then Locking_Policy
/= 'C'
11921 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11922 Set_Error_Msg_To_Profile_Name
;
11923 Error_Pragma
("Profile (~) incompatible with policy#");
11925 -- Set the Ceiling_Locking policy, but preserve System_Location since
11926 -- we like the error message with the run time name.
11929 Locking_Policy
:= 'C';
11931 if Locking_Policy_Sloc
/= System_Location
then
11932 Locking_Policy_Sloc
:= Loc
;
11936 -- pragma Detect_Blocking
11938 Detect_Blocking
:= True;
11940 -- Set the corresponding restrictions
11942 Set_Profile_Restrictions
11943 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11945 -- Set the No_Dependence restrictions
11947 -- The following No_Dependence restrictions:
11948 -- No_Dependence => Ada.Asynchronous_Task_Control
11949 -- No_Dependence => Ada.Calendar
11950 -- No_Dependence => Ada.Task_Attributes
11951 -- are already set by previous call to Set_Profile_Restrictions.
11954 -- Set the following restrictions which were added to Ada 2005:
11955 -- No_Dependence => Ada.Execution_Time.Group_Budget
11956 -- No_Dependence => Ada.Execution_Time.Timers
11958 if Ada_Version
>= Ada_2005
then
11960 Execution_Time
: constant Node_Id
:=
11961 Sel_Comp
("ada", "execution_time", Loc
);
11962 Group_Budgets
: constant Node_Id
:=
11963 Sel_Comp
(Execution_Time
, "group_budgets");
11964 Timers
: constant Node_Id
:=
11965 Sel_Comp
(Execution_Time
, "timers");
11967 Set_Restriction_No_Dependence
11968 (Unit
=> Group_Budgets
,
11969 Warn
=> Treat_Restrictions_As_Warnings
,
11970 Profile
=> Ravenscar
);
11971 Set_Restriction_No_Dependence
11973 Warn
=> Treat_Restrictions_As_Warnings
,
11974 Profile
=> Ravenscar
);
11978 -- Set the following restriction which was added to Ada 2012 (see
11980 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11982 if Ada_Version
>= Ada_2012
then
11983 Set_Restriction_No_Dependence
11985 (Sel_Comp
("system", "multiprocessors", Loc
),
11986 "dispatching_domains"),
11987 Warn
=> Treat_Restrictions_As_Warnings
,
11988 Profile
=> Ravenscar
);
11990 -- Set the following restriction which was added to Ada 2022,
11991 -- but as a binding interpretation:
11992 -- No_Dependence => Ada.Synchronous_Barriers
11993 -- for Ravenscar (and therefore for Ravenscar variants) but not
11994 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11995 -- in Ada2012 (AI05-0174).
11997 if Profile
/= Jorvik
then
11998 Set_Restriction_No_Dependence
11999 (Sel_Comp
("ada", "synchronous_barriers", Loc
),
12000 Warn
=> Treat_Restrictions_As_Warnings
,
12001 Profile
=> Ravenscar
);
12005 end Set_Ravenscar_Profile
;
12007 -- Start of processing for Analyze_Pragma
12010 -- The following code is a defense against recursion. Not clear that
12011 -- this can happen legitimately, but perhaps some error situations can
12012 -- cause it, and we did see this recursion during testing.
12014 if Analyzed
(N
) then
12020 Check_Restriction_No_Use_Of_Pragma
(N
);
12022 if Is_Aspect_Id
(Chars
(Pragma_Identifier
(N
))) then
12023 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
12024 -- no aspect_specification, attribute_definition_clause, or pragma
12026 Check_Restriction_No_Specification_Of_Aspect
(N
);
12029 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
12030 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
12032 if Should_Ignore_Pragma_Sem
(N
)
12033 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
12034 and then Ignore_Rep_Clauses
)
12039 -- Deal with unrecognized pragma
12041 if not Is_Pragma_Name
(Pname
) then
12043 Msg_Issued
: Boolean := False;
12046 (Msg_Issued
, No_Unrecognized_Pragmas
, Pragma_Identifier
(N
));
12047 if not Msg_Issued
and then Warn_On_Unrecognized_Pragma
then
12048 Error_Msg_Name_1
:= Pname
;
12049 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
12051 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
12052 if Is_Bad_Spelling_Of
(Pname
, PN
) then
12053 Error_Msg_Name_1
:= PN
;
12054 Error_Msg_N
-- CODEFIX
12055 ("\?g?possible misspelling of %!",
12056 Pragma_Identifier
(N
));
12066 -- Here to start processing for recognized pragma
12068 Pname
:= Original_Aspect_Pragma_Name
(N
);
12070 -- Capture setting of Opt.Uneval_Old
12072 case Opt
.Uneval_Old
is
12074 Set_Uneval_Old_Accept
(N
);
12080 Set_Uneval_Old_Warn
(N
);
12083 raise Program_Error
;
12086 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
12087 -- is already set, indicating that we have already checked the policy
12088 -- at the right point. This happens for example in the case of a pragma
12089 -- that is derived from an Aspect.
12091 if Is_Ignored
(N
) or else Is_Checked
(N
) then
12094 -- For a pragma that is a rewriting of another pragma, copy the
12095 -- Is_Checked/Is_Ignored status from the rewritten pragma.
12097 elsif Is_Rewrite_Substitution
(N
)
12098 and then Nkind
(Original_Node
(N
)) = N_Pragma
12100 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12101 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12103 -- Otherwise query the applicable policy at this point
12106 Check_Applicable_Policy
(N
);
12108 -- If pragma is disabled, rewrite as NULL and skip analysis
12110 if Is_Disabled
(N
) then
12111 Rewrite
(N
, Make_Null_Statement
(Loc
));
12117 -- Mark assertion pragmas as Ghost depending on their enclosing context
12119 if Assertion_Expression_Pragma
(Prag_Id
) then
12120 Mark_Ghost_Pragma
(N
, Current_Scope
);
12123 -- Preset arguments
12125 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
12126 Arg1
:= First
(Pragma_Argument_Associations
(N
));
12132 if Present
(Arg1
) then
12133 Arg2
:= Next
(Arg1
);
12135 if Present
(Arg2
) then
12136 Arg3
:= Next
(Arg2
);
12138 if Present
(Arg3
) then
12139 Arg4
:= Next
(Arg3
);
12141 if Present
(Arg4
) then
12142 Arg5
:= Next
(Arg4
);
12148 -- An enumeration type defines the pragmas that are supported by the
12149 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
12150 -- into the corresponding enumeration value for the following case.
12158 -- pragma Abort_Defer;
12160 when Pragma_Abort_Defer
=>
12162 Check_Arg_Count
(0);
12164 -- The only required semantic processing is to check the
12165 -- placement. This pragma must appear at the start of the
12166 -- statement sequence of a handled sequence of statements.
12168 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
12169 or else N
/= First
(Statements
(Parent
(N
)))
12174 --------------------
12175 -- Abstract_State --
12176 --------------------
12178 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
12180 -- ABSTRACT_STATE_LIST ::=
12182 -- | STATE_NAME_WITH_OPTIONS
12183 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
12185 -- STATE_NAME_WITH_OPTIONS ::=
12187 -- | (STATE_NAME with OPTION_LIST)
12189 -- OPTION_LIST ::= OPTION {, OPTION}
12193 -- | NAME_VALUE_OPTION
12195 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
12197 -- NAME_VALUE_OPTION ::=
12198 -- Part_Of => ABSTRACT_STATE
12199 -- | External [=> EXTERNAL_PROPERTY_LIST]
12201 -- EXTERNAL_PROPERTY_LIST ::=
12202 -- EXTERNAL_PROPERTY
12203 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
12205 -- EXTERNAL_PROPERTY ::=
12206 -- Async_Readers [=> boolean_EXPRESSION]
12207 -- | Async_Writers [=> boolean_EXPRESSION]
12208 -- | Effective_Reads [=> boolean_EXPRESSION]
12209 -- | Effective_Writes [=> boolean_EXPRESSION]
12210 -- others => boolean_EXPRESSION
12212 -- STATE_NAME ::= defining_identifier
12214 -- ABSTRACT_STATE ::= name
12216 -- Characteristics:
12218 -- * Analysis - The annotation is fully analyzed immediately upon
12219 -- elaboration as it cannot forward reference entities.
12221 -- * Expansion - None.
12223 -- * Template - The annotation utilizes the generic template of the
12224 -- related package declaration.
12226 -- * Globals - The annotation cannot reference global entities.
12228 -- * Instance - The annotation is instantiated automatically when
12229 -- the related generic package is instantiated.
12231 when Pragma_Abstract_State
=> Abstract_State
: declare
12232 Missing_Parentheses
: Boolean := False;
12233 -- Flag set when a state declaration with options is not properly
12236 -- Flags used to verify the consistency of states
12238 Non_Null_Seen
: Boolean := False;
12239 Null_Seen
: Boolean := False;
12241 procedure Analyze_Abstract_State
12243 Pack_Id
: Entity_Id
);
12244 -- Verify the legality of a single state declaration. Create and
12245 -- decorate a state abstraction entity and introduce it into the
12246 -- visibility chain. Pack_Id denotes the entity or the related
12247 -- package where pragma Abstract_State appears.
12249 procedure Malformed_State_Error
(State
: Node_Id
);
12250 -- Emit an error concerning the illegal declaration of abstract
12251 -- state State. This routine diagnoses syntax errors that lead to
12252 -- a different parse tree. The error is issued regardless of the
12253 -- SPARK mode in effect.
12255 ----------------------------
12256 -- Analyze_Abstract_State --
12257 ----------------------------
12259 procedure Analyze_Abstract_State
12261 Pack_Id
: Entity_Id
)
12263 -- Flags used to verify the consistency of options
12265 AR_Seen
: Boolean := False;
12266 AW_Seen
: Boolean := False;
12267 ER_Seen
: Boolean := False;
12268 EW_Seen
: Boolean := False;
12269 External_Seen
: Boolean := False;
12270 Ghost_Seen
: Boolean := False;
12271 Others_Seen
: Boolean := False;
12272 Part_Of_Seen
: Boolean := False;
12273 Relaxed_Initialization_Seen
: Boolean := False;
12274 Synchronous_Seen
: Boolean := False;
12276 -- Flags used to store the static value of all external states'
12279 AR_Val
: Boolean := False;
12280 AW_Val
: Boolean := False;
12281 ER_Val
: Boolean := False;
12282 EW_Val
: Boolean := False;
12284 State_Id
: Entity_Id
:= Empty
;
12285 -- The entity to be generated for the current state declaration
12287 procedure Analyze_External_Option
(Opt
: Node_Id
);
12288 -- Verify the legality of option External
12290 procedure Analyze_External_Property
12292 Expr
: Node_Id
:= Empty
);
12293 -- Verify the legailty of a single external property. Prop
12294 -- denotes the external property. Expr is the expression used
12295 -- to set the property.
12297 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
12298 -- Verify the legality of option Part_Of
12300 procedure Check_Duplicate_Option
12302 Status
: in out Boolean);
12303 -- Flag Status denotes whether a particular option has been
12304 -- seen while processing a state. This routine verifies that
12305 -- Opt is not a duplicate option and sets the flag Status
12306 -- (SPARK RM 7.1.4(1)).
12308 procedure Check_Duplicate_Property
12310 Status
: in out Boolean);
12311 -- Flag Status denotes whether a particular property has been
12312 -- seen while processing option External. This routine verifies
12313 -- that Prop is not a duplicate property and sets flag Status.
12314 -- Opt is not a duplicate property and sets the flag Status.
12315 -- (SPARK RM 7.1.4(2))
12317 procedure Check_Ghost_Synchronous
;
12318 -- Ensure that the abstract state is not subject to both Ghost
12319 -- and Synchronous simple options. Emit an error if this is the
12322 procedure Create_Abstract_State
12326 Is_Null
: Boolean);
12327 -- Generate an abstract state entity with name Nam and enter it
12328 -- into visibility. Decl is the "declaration" of the state as
12329 -- it appears in pragma Abstract_State. Loc is the location of
12330 -- the related state "declaration". Flag Is_Null should be set
12331 -- when the associated Abstract_State pragma defines a null
12334 -----------------------------
12335 -- Analyze_External_Option --
12336 -----------------------------
12338 procedure Analyze_External_Option
(Opt
: Node_Id
) is
12339 Errors
: constant Nat
:= Serious_Errors_Detected
;
12341 Props
: Node_Id
:= Empty
;
12344 if Nkind
(Opt
) = N_Component_Association
then
12345 Props
:= Expression
(Opt
);
12348 -- External state with properties
12350 if Present
(Props
) then
12352 -- Multiple properties appear as an aggregate
12354 if Nkind
(Props
) = N_Aggregate
then
12356 -- Simple property form
12358 Prop
:= First
(Expressions
(Props
));
12359 while Present
(Prop
) loop
12360 Analyze_External_Property
(Prop
);
12364 -- Property with expression form
12366 Prop
:= First
(Component_Associations
(Props
));
12367 while Present
(Prop
) loop
12368 Analyze_External_Property
12369 (Prop
=> First
(Choices
(Prop
)),
12370 Expr
=> Expression
(Prop
));
12378 Analyze_External_Property
(Props
);
12381 -- An external state defined without any properties defaults
12382 -- all properties to True.
12391 -- Once all external properties have been processed, verify
12392 -- their mutual interaction. Do not perform the check when
12393 -- at least one of the properties is illegal as this will
12394 -- produce a bogus error.
12396 if Errors
= Serious_Errors_Detected
then
12397 Check_External_Properties
12398 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
12400 end Analyze_External_Option
;
12402 -------------------------------
12403 -- Analyze_External_Property --
12404 -------------------------------
12406 procedure Analyze_External_Property
12408 Expr
: Node_Id
:= Empty
)
12410 Expr_Val
: Boolean;
12413 -- Check the placement of "others" (if available)
12415 if Nkind
(Prop
) = N_Others_Choice
then
12416 if Others_Seen
then
12418 ("only one OTHERS choice allowed in option External",
12421 Others_Seen
:= True;
12424 elsif Others_Seen
then
12426 ("OTHERS must be the last property in option External",
12429 -- The only remaining legal options are the four predefined
12430 -- external properties.
12432 elsif Nkind
(Prop
) = N_Identifier
12433 and then Chars
(Prop
) in Name_Async_Readers
12434 | Name_Async_Writers
12435 | Name_Effective_Reads
12436 | Name_Effective_Writes
12440 -- Otherwise the construct is not a valid property
12443 SPARK_Msg_N
("invalid external state property", Prop
);
12447 -- Ensure that the expression of the external state property
12448 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12450 if Present
(Expr
) then
12451 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
12453 if Is_OK_Static_Expression
(Expr
) then
12454 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
12457 ("expression of external state property must be "
12462 -- The lack of expression defaults the property to True
12468 -- Named properties
12470 if Nkind
(Prop
) = N_Identifier
then
12471 if Chars
(Prop
) = Name_Async_Readers
then
12472 Check_Duplicate_Property
(Prop
, AR_Seen
);
12473 AR_Val
:= Expr_Val
;
12475 elsif Chars
(Prop
) = Name_Async_Writers
then
12476 Check_Duplicate_Property
(Prop
, AW_Seen
);
12477 AW_Val
:= Expr_Val
;
12479 elsif Chars
(Prop
) = Name_Effective_Reads
then
12480 Check_Duplicate_Property
(Prop
, ER_Seen
);
12481 ER_Val
:= Expr_Val
;
12484 Check_Duplicate_Property
(Prop
, EW_Seen
);
12485 EW_Val
:= Expr_Val
;
12488 -- The handling of property "others" must take into account
12489 -- all other named properties that have been encountered so
12490 -- far. Only those that have not been seen are affected by
12494 if not AR_Seen
then
12495 AR_Val
:= Expr_Val
;
12498 if not AW_Seen
then
12499 AW_Val
:= Expr_Val
;
12502 if not ER_Seen
then
12503 ER_Val
:= Expr_Val
;
12506 if not EW_Seen
then
12507 EW_Val
:= Expr_Val
;
12510 end Analyze_External_Property
;
12512 ----------------------------
12513 -- Analyze_Part_Of_Option --
12514 ----------------------------
12516 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
12517 Encap
: constant Node_Id
:= Expression
(Opt
);
12518 Constits
: Elist_Id
;
12519 Encap_Id
: Entity_Id
;
12523 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
12526 (Indic
=> First
(Choices
(Opt
)),
12527 Item_Id
=> State_Id
,
12529 Encap_Id
=> Encap_Id
,
12532 -- The Part_Of indicator transforms the abstract state into
12533 -- a constituent of the encapsulating state or single
12534 -- concurrent type.
12537 pragma Assert
(Present
(Encap_Id
));
12538 Constits
:= Part_Of_Constituents
(Encap_Id
);
12540 if No
(Constits
) then
12541 Constits
:= New_Elmt_List
;
12542 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12545 Append_Elmt
(State_Id
, Constits
);
12546 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12548 end Analyze_Part_Of_Option
;
12550 ----------------------------
12551 -- Check_Duplicate_Option --
12552 ----------------------------
12554 procedure Check_Duplicate_Option
12556 Status
: in out Boolean)
12560 SPARK_Msg_N
("duplicate state option", Opt
);
12564 end Check_Duplicate_Option
;
12566 ------------------------------
12567 -- Check_Duplicate_Property --
12568 ------------------------------
12570 procedure Check_Duplicate_Property
12572 Status
: in out Boolean)
12576 SPARK_Msg_N
("duplicate external property", Prop
);
12580 end Check_Duplicate_Property
;
12582 -----------------------------
12583 -- Check_Ghost_Synchronous --
12584 -----------------------------
12586 procedure Check_Ghost_Synchronous
is
12588 -- A synchronized abstract state cannot be Ghost and vice
12589 -- versa (SPARK RM 6.9(19)).
12591 if Ghost_Seen
and Synchronous_Seen
then
12592 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12594 end Check_Ghost_Synchronous
;
12596 ---------------------------
12597 -- Create_Abstract_State --
12598 ---------------------------
12600 procedure Create_Abstract_State
12607 -- The abstract state may be semi-declared when the related
12608 -- package was withed through a limited with clause. In that
12609 -- case reuse the entity to fully declare the state.
12611 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12612 State_Id
:= Entity
(Decl
);
12614 -- Otherwise the elaboration of pragma Abstract_State
12615 -- declares the state.
12618 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12620 if Present
(Decl
) then
12621 Set_Entity
(Decl
, State_Id
);
12625 -- Null states never come from source
12627 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12628 Set_Parent
(State_Id
, State
);
12629 Mutate_Ekind
(State_Id
, E_Abstract_State
);
12630 Set_Is_Not_Self_Hidden
(State_Id
);
12631 Set_Etype
(State_Id
, Standard_Void_Type
);
12632 Set_Encapsulating_State
(State_Id
, Empty
);
12634 -- Set the SPARK mode from the current context
12636 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12637 Set_SPARK_Pragma_Inherited
(State_Id
);
12639 -- An abstract state declared within a Ghost region becomes
12640 -- Ghost (SPARK RM 6.9(2)).
12642 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12643 Set_Is_Ghost_Entity
(State_Id
);
12646 -- Establish a link between the state declaration and the
12647 -- abstract state entity. Note that a null state remains as
12648 -- N_Null and does not carry any linkages.
12650 if not Is_Null
then
12651 if Present
(Decl
) then
12652 Set_Entity
(Decl
, State_Id
);
12653 Set_Etype
(Decl
, Standard_Void_Type
);
12656 -- Every non-null state must be defined, nameable and
12659 Push_Scope
(Pack_Id
);
12660 Generate_Definition
(State_Id
);
12661 Enter_Name
(State_Id
);
12664 end Create_Abstract_State
;
12671 -- Start of processing for Analyze_Abstract_State
12674 -- A package with a null abstract state is not allowed to
12675 -- declare additional states.
12679 ("package & has null abstract state", State
, Pack_Id
);
12681 -- Null states appear as internally generated entities
12683 elsif Nkind
(State
) = N_Null
then
12684 Create_Abstract_State
12685 (Nam
=> New_Internal_Name
('S'),
12687 Loc
=> Sloc
(State
),
12691 -- Catch a case where a null state appears in a list of
12692 -- non-null states.
12694 if Non_Null_Seen
then
12696 ("package & has non-null abstract state",
12700 -- Simple state declaration
12702 elsif Nkind
(State
) = N_Identifier
then
12703 Create_Abstract_State
12704 (Nam
=> Chars
(State
),
12706 Loc
=> Sloc
(State
),
12708 Non_Null_Seen
:= True;
12710 -- State declaration with various options. This construct
12711 -- appears as an extension aggregate in the tree.
12713 elsif Nkind
(State
) = N_Extension_Aggregate
then
12714 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12715 Create_Abstract_State
12716 (Nam
=> Chars
(Ancestor_Part
(State
)),
12717 Decl
=> Ancestor_Part
(State
),
12718 Loc
=> Sloc
(Ancestor_Part
(State
)),
12720 Non_Null_Seen
:= True;
12723 ("state name must be an identifier",
12724 Ancestor_Part
(State
));
12727 -- Options External, Ghost and Synchronous appear as
12730 Opt
:= First
(Expressions
(State
));
12731 while Present
(Opt
) loop
12732 if Nkind
(Opt
) = N_Identifier
then
12736 if Chars
(Opt
) = Name_External
then
12737 Check_Duplicate_Option
(Opt
, External_Seen
);
12738 Analyze_External_Option
(Opt
);
12742 elsif Chars
(Opt
) = Name_Ghost
then
12743 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12744 Check_Ghost_Synchronous
;
12746 if Present
(State_Id
) then
12747 Set_Is_Ghost_Entity
(State_Id
);
12752 elsif Chars
(Opt
) = Name_Synchronous
then
12753 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12754 Check_Ghost_Synchronous
;
12756 -- Relaxed_Initialization
12758 elsif Chars
(Opt
) = Name_Relaxed_Initialization
then
12759 Check_Duplicate_Option
12760 (Opt
, Relaxed_Initialization_Seen
);
12762 -- Option Part_Of without an encapsulating state is
12763 -- illegal (SPARK RM 7.1.4(8)).
12765 elsif Chars
(Opt
) = Name_Part_Of
then
12767 ("indicator Part_Of must denote abstract state, "
12768 & "single protected type or single task type",
12771 -- Do not emit an error message when a previous state
12772 -- declaration with options was not parenthesized as
12773 -- the option is actually another state declaration.
12775 -- with Abstract_State
12776 -- (State_1 with ..., -- missing parentheses
12777 -- (State_2 with ...),
12778 -- State_3) -- ok state declaration
12780 elsif Missing_Parentheses
then
12783 -- Otherwise the option is not allowed. Note that it
12784 -- is not possible to distinguish between an option
12785 -- and a state declaration when a previous state with
12786 -- options not properly parentheses.
12788 -- with Abstract_State
12789 -- (State_1 with ..., -- missing parentheses
12790 -- State_2); -- could be an option
12794 ("simple option not allowed in state declaration",
12798 -- Catch a case where missing parentheses around a state
12799 -- declaration with options cause a subsequent state
12800 -- declaration with options to be treated as an option.
12802 -- with Abstract_State
12803 -- (State_1 with ..., -- missing parentheses
12804 -- (State_2 with ...))
12806 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12807 Missing_Parentheses
:= True;
12809 ("state declaration must be parenthesized",
12810 Ancestor_Part
(State
));
12812 -- Otherwise the option is malformed
12815 SPARK_Msg_N
("malformed option", Opt
);
12821 -- Options External and Part_Of appear as component
12824 Opt
:= First
(Component_Associations
(State
));
12825 while Present
(Opt
) loop
12826 Opt_Nam
:= First
(Choices
(Opt
));
12828 if Nkind
(Opt_Nam
) = N_Identifier
then
12829 if Chars
(Opt_Nam
) = Name_External
then
12830 Analyze_External_Option
(Opt
);
12832 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12833 Analyze_Part_Of_Option
(Opt
);
12836 SPARK_Msg_N
("invalid state option", Opt
);
12839 SPARK_Msg_N
("invalid state option", Opt
);
12845 -- Any other attempt to declare a state is illegal
12848 Malformed_State_Error
(State
);
12852 -- Guard against a junk state. In such cases no entity is
12853 -- generated and the subsequent checks cannot be applied.
12855 if Present
(State_Id
) then
12857 -- Verify whether the state does not introduce an illegal
12858 -- hidden state within a package subject to a null abstract
12861 Check_No_Hidden_State
(State_Id
);
12863 -- Check whether the lack of option Part_Of agrees with the
12864 -- placement of the abstract state with respect to the state
12867 if not Part_Of_Seen
then
12868 Check_Missing_Part_Of
(State_Id
);
12871 -- Associate the state with its related package
12873 if No
(Abstract_States
(Pack_Id
)) then
12874 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12877 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12879 end Analyze_Abstract_State
;
12881 ---------------------------
12882 -- Malformed_State_Error --
12883 ---------------------------
12885 procedure Malformed_State_Error
(State
: Node_Id
) is
12887 Error_Msg_N
("malformed abstract state declaration", State
);
12889 -- An abstract state with a simple option is being declared
12890 -- with "=>" rather than the legal "with". The state appears
12891 -- as a component association.
12893 if Nkind
(State
) = N_Component_Association
then
12894 Error_Msg_N
("\use WITH to specify simple option", State
);
12896 end Malformed_State_Error
;
12900 Pack_Decl
: Node_Id
;
12901 Pack_Id
: Entity_Id
;
12905 -- Start of processing for Abstract_State
12909 Check_No_Identifiers
;
12910 Check_Arg_Count
(1);
12912 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12914 if Nkind
(Pack_Decl
) not in
12915 N_Generic_Package_Declaration | N_Package_Declaration
12920 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12922 -- A pragma that applies to a Ghost entity becomes Ghost for the
12923 -- purposes of legality checks and removal of ignored Ghost code.
12925 Mark_Ghost_Pragma
(N
, Pack_Id
);
12926 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12928 -- Chain the pragma on the contract for completeness
12930 Add_Contract_Item
(N
, Pack_Id
);
12932 -- The legality checks of pragmas Abstract_State, Initializes, and
12933 -- Initial_Condition are affected by the SPARK mode in effect. In
12934 -- addition, these three pragmas are subject to an inherent order:
12936 -- 1) Abstract_State
12938 -- 3) Initial_Condition
12940 -- Analyze all these pragmas in the order outlined above
12942 Analyze_If_Present
(Pragma_SPARK_Mode
);
12943 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12945 -- Multiple non-null abstract states appear as an aggregate
12947 if Nkind
(States
) = N_Aggregate
then
12948 State
:= First
(Expressions
(States
));
12949 while Present
(State
) loop
12950 Analyze_Abstract_State
(State
, Pack_Id
);
12954 -- An abstract state with a simple option is being illegaly
12955 -- declared with "=>" rather than "with". In this case the
12956 -- state declaration appears as a component association.
12958 if Present
(Component_Associations
(States
)) then
12959 State
:= First
(Component_Associations
(States
));
12960 while Present
(State
) loop
12961 Malformed_State_Error
(State
);
12966 -- Various forms of a single abstract state. Note that these may
12967 -- include malformed state declarations.
12970 Analyze_Abstract_State
(States
, Pack_Id
);
12973 Analyze_If_Present
(Pragma_Initializes
);
12974 Analyze_If_Present
(Pragma_Initial_Condition
);
12975 end Abstract_State
;
12983 -- Note: this pragma also has some specific processing in Par.Prag
12984 -- because we want to set the Ada version mode during parsing.
12986 when Pragma_Ada_83
=>
12988 Check_Arg_Count
(0);
12990 -- We really should check unconditionally for proper configuration
12991 -- pragma placement, since we really don't want mixed Ada modes
12992 -- within a single unit, and the GNAT reference manual has always
12993 -- said this was a configuration pragma, but we did not check and
12994 -- are hesitant to add the check now.
12996 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12997 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12998 -- or Ada 2012 mode.
13000 if Ada_Version
>= Ada_2005
then
13001 Check_Valid_Configuration_Pragma
;
13004 -- Now set Ada 83 mode
13006 if Latest_Ada_Only
then
13007 Error_Pragma
("??pragma% ignored");
13009 Ada_Version
:= Ada_83
;
13010 Ada_Version_Explicit
:= Ada_83
;
13011 Ada_Version_Pragma
:= N
;
13020 -- Note: this pragma also has some specific processing in Par.Prag
13021 -- because we want to set the Ada 83 version mode during parsing.
13023 when Pragma_Ada_95
=>
13025 Check_Arg_Count
(0);
13027 -- We really should check unconditionally for proper configuration
13028 -- pragma placement, since we really don't want mixed Ada modes
13029 -- within a single unit, and the GNAT reference manual has always
13030 -- said this was a configuration pragma, but we did not check and
13031 -- are hesitant to add the check now.
13033 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
13034 -- or Ada 95, so we must check if we are in Ada 2005 mode.
13036 if Ada_Version
>= Ada_2005
then
13037 Check_Valid_Configuration_Pragma
;
13040 -- Now set Ada 95 mode
13042 if Latest_Ada_Only
then
13043 Error_Pragma
("??pragma% ignored");
13045 Ada_Version
:= Ada_95
;
13046 Ada_Version_Explicit
:= Ada_95
;
13047 Ada_Version_Pragma
:= N
;
13050 ---------------------
13051 -- Ada_05/Ada_2005 --
13052 ---------------------
13055 -- pragma Ada_05 (LOCAL_NAME);
13057 -- pragma Ada_2005;
13058 -- pragma Ada_2005 (LOCAL_NAME):
13060 -- Note: these pragmas also have some specific processing in Par.Prag
13061 -- because we want to set the Ada 2005 version mode during parsing.
13063 -- The one argument form is used for managing the transition from
13064 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
13065 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
13066 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
13067 -- mode, a preference rule is established which does not choose
13068 -- such an entity unless it is unambiguously specified. This avoids
13069 -- extra subprograms marked this way from generating ambiguities in
13070 -- otherwise legal pre-Ada_2005 programs. The one argument form is
13071 -- intended for exclusive use in the GNAT run-time library.
13082 if Arg_Count
= 1 then
13083 Check_Arg_Is_Local_Name
(Arg1
);
13084 E_Id
:= Get_Pragma_Arg
(Arg1
);
13086 if Etype
(E_Id
) = Any_Type
then
13090 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
13091 Record_Rep_Item
(Entity
(E_Id
), N
);
13094 Check_Arg_Count
(0);
13096 -- For Ada_2005 we unconditionally enforce the documented
13097 -- configuration pragma placement, since we do not want to
13098 -- tolerate mixed modes in a unit involving Ada 2005. That
13099 -- would cause real difficulties for those cases where there
13100 -- are incompatibilities between Ada 95 and Ada 2005.
13102 Check_Valid_Configuration_Pragma
;
13104 -- Now set appropriate Ada mode
13106 if Latest_Ada_Only
then
13107 Error_Pragma
("??pragma% ignored");
13109 Ada_Version
:= Ada_2005
;
13110 Ada_Version_Explicit
:= Ada_2005
;
13111 Ada_Version_Pragma
:= N
;
13116 ---------------------
13117 -- Ada_12/Ada_2012 --
13118 ---------------------
13121 -- pragma Ada_12 (LOCAL_NAME);
13123 -- pragma Ada_2012;
13124 -- pragma Ada_2012 (LOCAL_NAME):
13126 -- Note: these pragmas also have some specific processing in Par.Prag
13127 -- because we want to set the Ada 2012 version mode during parsing.
13129 -- The one argument form is used for managing the transition from Ada
13130 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
13131 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
13132 -- mode will generate a warning. In addition, in any pre-Ada_2012
13133 -- mode, a preference rule is established which does not choose
13134 -- such an entity unless it is unambiguously specified. This avoids
13135 -- extra subprograms marked this way from generating ambiguities in
13136 -- otherwise legal pre-Ada_2012 programs. The one argument form is
13137 -- intended for exclusive use in the GNAT run-time library.
13148 if Arg_Count
= 1 then
13149 Check_Arg_Is_Local_Name
(Arg1
);
13150 E_Id
:= Get_Pragma_Arg
(Arg1
);
13152 if Etype
(E_Id
) = Any_Type
then
13156 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
13157 Record_Rep_Item
(Entity
(E_Id
), N
);
13160 Check_Arg_Count
(0);
13162 -- For Ada_2012 we unconditionally enforce the documented
13163 -- configuration pragma placement, since we do not want to
13164 -- tolerate mixed modes in a unit involving Ada 2012. That
13165 -- would cause real difficulties for those cases where there
13166 -- are incompatibilities between Ada 95 and Ada 2012. We could
13167 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
13169 Check_Valid_Configuration_Pragma
;
13171 -- Now set appropriate Ada mode
13173 Ada_Version
:= Ada_2012
;
13174 Ada_Version_Explicit
:= Ada_2012
;
13175 Ada_Version_Pragma
:= N
;
13183 -- pragma Ada_2022;
13184 -- pragma Ada_2022 (LOCAL_NAME):
13186 -- Note: this pragma also has some specific processing in Par.Prag
13187 -- because we want to set the Ada 2022 version mode during parsing.
13189 -- The one argument form is used for managing the transition from Ada
13190 -- 2012 to Ada 2022 in the run-time library. If an entity is marked
13191 -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
13192 -- mode will generate a warning;for calls to Ada_2022 only primitives
13193 -- that require overriding an error will be reported. In addition, in
13194 -- any pre-Ada_2022 mode, a preference rule is established which does
13195 -- not choose such an entity unless it is unambiguously specified.
13196 -- This avoids extra subprograms marked this way from generating
13197 -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
13198 -- argument form is intended for exclusive use in the GNAT run-time
13201 when Pragma_Ada_2022
=>
13208 if Arg_Count
= 1 then
13209 Check_Arg_Is_Local_Name
(Arg1
);
13210 E_Id
:= Get_Pragma_Arg
(Arg1
);
13212 if Etype
(E_Id
) = Any_Type
then
13216 Set_Is_Ada_2022_Only
(Entity
(E_Id
));
13217 Record_Rep_Item
(Entity
(E_Id
), N
);
13220 Check_Arg_Count
(0);
13222 -- For Ada_2022 we unconditionally enforce the documented
13223 -- configuration pragma placement, since we do not want to
13224 -- tolerate mixed modes in a unit involving Ada 2022. That
13225 -- would cause real difficulties for those cases where there
13226 -- are incompatibilities between Ada 2012 and Ada 2022. We
13227 -- could allow mixing of Ada 2012 and Ada 2022 but it's not
13230 Check_Valid_Configuration_Pragma
;
13232 -- Now set appropriate Ada mode
13234 Ada_Version
:= Ada_2022
;
13235 Ada_Version_Explicit
:= Ada_2022
;
13236 Ada_Version_Pragma
:= N
;
13240 -------------------------------------
13241 -- Aggregate_Individually_Assign --
13242 -------------------------------------
13244 -- pragma Aggregate_Individually_Assign;
13246 when Pragma_Aggregate_Individually_Assign
=>
13248 Check_Arg_Count
(0);
13249 Check_Valid_Configuration_Pragma
;
13250 Aggregate_Individually_Assign
:= True;
13252 ----------------------
13253 -- All_Calls_Remote --
13254 ----------------------
13256 -- pragma All_Calls_Remote [(library_package_NAME)];
13258 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
13259 Lib_Entity
: Entity_Id
;
13262 Check_Ada_83_Warning
;
13263 Check_Valid_Library_Unit_Pragma
;
13265 -- If N was rewritten as a null statement there is nothing more
13268 if Nkind
(N
) = N_Null_Statement
then
13272 Lib_Entity
:= Find_Lib_Unit_Name
;
13274 -- A pragma that applies to a Ghost entity becomes Ghost for the
13275 -- purposes of legality checks and removal of ignored Ghost code.
13277 Mark_Ghost_Pragma
(N
, Lib_Entity
);
13279 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
13281 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
13282 if not Is_Remote_Call_Interface
(Lib_Entity
) then
13283 Error_Pragma
("pragma% only apply to rci unit");
13285 -- Set flag for entity of the library unit
13288 Set_Has_All_Calls_Remote
(Lib_Entity
);
13291 end All_Calls_Remote
;
13293 ---------------------------
13294 -- Allow_Integer_Address --
13295 ---------------------------
13297 -- pragma Allow_Integer_Address;
13299 when Pragma_Allow_Integer_Address
=>
13301 Check_Valid_Configuration_Pragma
;
13302 Check_Arg_Count
(0);
13304 -- If Address is a private type, then set the flag to allow
13305 -- integer address values. If Address is not private, then this
13306 -- pragma has no purpose, so it is simply ignored. Not clear if
13307 -- there are any such targets now.
13309 if Opt
.Address_Is_Private
then
13310 Opt
.Allow_Integer_Address
:= True;
13313 -----------------------
13314 -- Always_Terminates --
13315 -----------------------
13317 -- pragma Always_Terminates [ (boolean_EXPRESSION) ];
13319 -- Characteristics:
13321 -- * Analysis - The annotation undergoes initial checks to verify
13322 -- the legal placement and context. Secondary checks preanalyze the
13325 -- Analyze_Always_Terminates_Cases_In_Decl_Part
13327 -- * Expansion - The annotation is expanded during the expansion of
13328 -- the related subprogram [body] contract as performed in:
13330 -- Expand_Subprogram_Contract
13332 -- * Template - The annotation utilizes the generic template of the
13333 -- related subprogram [body] when it is:
13335 -- aspect on subprogram declaration
13336 -- aspect on stand-alone subprogram body
13337 -- pragma on stand-alone subprogram body
13339 -- The annotation must prepare its own template when it is:
13341 -- pragma on subprogram declaration
13343 -- * Globals - Capture of global references must occur after full
13346 -- * Instance - The annotation is instantiated automatically when
13347 -- the related generic subprogram [body] is instantiated except for
13348 -- the "pragma on subprogram declaration" case. In that scenario
13349 -- the annotation must instantiate itself.
13351 when Pragma_Always_Terminates
=> Always_Terminates
: declare
13352 Spec_Id
: Entity_Id
;
13353 Subp_Decl
: Node_Id
;
13354 Subp_Spec
: Node_Id
;
13358 Check_No_Identifiers
;
13359 Check_At_Most_N_Arguments
(1);
13361 -- Ensure the proper placement of the pragma. Always_Terminates
13362 -- must be associated with a subprogram declaration or a body that
13366 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13368 -- Generic subprogram and package declaration
13370 if Nkind
(Subp_Decl
) in N_Generic_Declaration
then
13373 -- Package declaration
13375 elsif Nkind
(Subp_Decl
) = N_Package_Declaration
then
13378 -- Body acts as spec
13380 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13381 and then No
(Corresponding_Spec
(Subp_Decl
))
13385 -- Body stub acts as spec
13387 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13388 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13394 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13395 Subp_Spec
:= Specification
(Subp_Decl
);
13397 -- Pragma Always_Terminates is forbidden on null procedures,
13398 -- as this may lead to potential ambiguities in behavior
13399 -- when interface null procedures are involved. Also, it
13400 -- just wouldn't make sense, because null procedures always
13401 -- terminate anyway.
13403 if Nkind
(Subp_Spec
) = N_Procedure_Specification
13404 and then Null_Present
(Subp_Spec
)
13406 Error_Msg_N
(Fix_Error
13407 ("pragma % cannot apply to null procedure"), N
);
13413 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13420 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13422 -- In order to call Is_Function_With_Side_Effects, analyze pragma
13423 -- Side_Effects if present.
13425 Analyze_If_Present
(Pragma_Side_Effects
);
13427 -- Pragma Always_Terminates is not allowed on functions without
13430 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
13431 and then not Is_Function_With_Side_Effects
(Spec_Id
)
13433 Error_Msg_Code
:= GEC_Always_Terminates_On_Function
;
13435 if Ekind
(Spec_Id
) = E_Function
then
13436 Error_Msg_N
(Fix_Error
13437 ("pragma % cannot apply to function '[[]']"), N
);
13440 elsif Ekind
(Spec_Id
) = E_Generic_Function
then
13441 Error_Msg_N
(Fix_Error
13442 ("pragma % cannot apply to generic function '[[]']"), N
);
13447 -- Pragma Always_Terminates applied to packages doesn't allow any
13450 if Is_Package_Or_Generic_Package
(Spec_Id
)
13451 and then Arg_Count
/= 0
13453 Error_Msg_N
(Fix_Error
13454 ("pragma % applied to package cannot have arguments"), N
);
13458 -- A pragma that applies to a Ghost entity becomes Ghost for the
13459 -- purposes of legality checks and removal of ignored Ghost code.
13461 Mark_Ghost_Pragma
(N
, Spec_Id
);
13463 -- Chain the pragma on the contract for further processing by
13464 -- Analyze_Always_Terminates_In_Decl_Part.
13466 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13468 -- Fully analyze the pragma when it appears inside a subprogram
13469 -- body because it cannot benefit from forward references.
13471 if Nkind
(Subp_Decl
) in N_Subprogram_Body
13472 | N_Subprogram_Body_Stub
13474 -- The legality checks of pragma Always_Terminates are affected
13475 -- by the SPARK mode in effect and the volatility of the
13476 -- context. Analyze all pragmas in a specific order.
13478 Analyze_If_Present
(Pragma_SPARK_Mode
);
13479 Analyze_If_Present
(Pragma_Volatile_Function
);
13480 Analyze_Always_Terminates_In_Decl_Part
(N
);
13482 end Always_Terminates
;
13489 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13490 -- ARG ::= NAME | EXPRESSION
13492 -- The first two arguments are by convention intended to refer to an
13493 -- external tool and a tool-specific function. These arguments are
13496 when Pragma_Annotate | Pragma_GNAT_Annotate
=> Annotate
: declare
13501 --------------------------
13502 -- Inferred_String_Type --
13503 --------------------------
13505 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
;
13506 -- Infer the type to use for a string literal or a concatentation
13507 -- of operands whose types can be inferred. For such expressions,
13508 -- returns the "narrowest" of the three predefined string types
13509 -- that can represent the characters occurring in the expression.
13510 -- For other expressions, returns Empty.
13512 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
is
13514 case Nkind
(Expr
) is
13515 when N_String_Literal
=>
13516 if Has_Wide_Wide_Character
(Expr
) then
13517 return Standard_Wide_Wide_String
;
13518 elsif Has_Wide_Character
(Expr
) then
13519 return Standard_Wide_String
;
13521 return Standard_String
;
13524 when N_Op_Concat
=>
13526 L_Type
: constant Entity_Id
13527 := Preferred_String_Type
(Left_Opnd
(Expr
));
13528 R_Type
: constant Entity_Id
13529 := Preferred_String_Type
(Right_Opnd
(Expr
));
13531 Type_Table
: constant array (1 .. 4) of Entity_Id
13533 Standard_Wide_Wide_String
,
13534 Standard_Wide_String
,
13537 for Idx
in Type_Table
'Range loop
13538 if L_Type
= Type_Table
(Idx
) or
13539 R_Type
= Type_Table
(Idx
)
13541 return Type_Table
(Idx
);
13544 raise Program_Error
;
13550 end Preferred_String_Type
;
13553 Check_At_Least_N_Arguments
(1);
13555 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
13557 -- Determine whether the last argument is "Entity => local_NAME"
13558 -- and if it is, perform the required semantic checks. Remove the
13559 -- argument from further processing.
13561 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
13562 and then Chars
(Nam_Arg
) = Name_Entity
13564 Check_Arg_Is_Local_Name
(Nam_Arg
);
13565 Arg_Count
:= Arg_Count
- 1;
13567 -- A pragma that applies to a Ghost entity becomes Ghost for
13568 -- the purposes of legality checks and removal of ignored Ghost
13571 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
13572 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
13574 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
13578 -- Continue the processing with last argument removed for now
13580 Check_Arg_Is_Identifier
(Arg1
);
13581 Check_No_Identifiers
;
13584 -- The second parameter is optional, it is never analyzed
13589 -- Otherwise there is a second parameter
13592 -- The second parameter must be an identifier
13594 Check_Arg_Is_Identifier
(Arg2
);
13596 -- Process the remaining parameters (if any)
13598 Arg
:= Next
(Arg2
);
13599 while Present
(Arg
) loop
13600 Expr
:= Get_Pragma_Arg
(Arg
);
13603 if Is_Entity_Name
(Expr
) then
13606 -- For string literals and concatenations of string literals
13607 -- we assume Standard_String as the type, unless the string
13608 -- contains wide or wide_wide characters.
13610 elsif Present
(Preferred_String_Type
(Expr
)) then
13611 Resolve
(Expr
, Preferred_String_Type
(Expr
));
13613 elsif Is_Overloaded
(Expr
) then
13614 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13625 -------------------------------------------------
13626 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13627 -------------------------------------------------
13630 -- ( [Check => ] Boolean_EXPRESSION
13631 -- [, [Message =>] Static_String_EXPRESSION]);
13633 -- pragma Assert_And_Cut
13634 -- ( [Check => ] Boolean_EXPRESSION
13635 -- [, [Message =>] Static_String_EXPRESSION]);
13638 -- ( [Check => ] Boolean_EXPRESSION
13639 -- [, [Message =>] Static_String_EXPRESSION]);
13641 -- pragma Loop_Invariant
13642 -- ( [Check => ] Boolean_EXPRESSION
13643 -- [, [Message =>] Static_String_EXPRESSION]);
13646 | Pragma_Assert_And_Cut
13648 | Pragma_Loop_Invariant
13651 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13652 -- Determine whether expression Expr contains a Loop_Entry
13653 -- attribute reference.
13655 -------------------------
13656 -- Contains_Loop_Entry --
13657 -------------------------
13659 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13660 Has_Loop_Entry
: Boolean := False;
13662 function Process
(N
: Node_Id
) return Traverse_Result
;
13663 -- Process function for traversal to look for Loop_Entry
13669 function Process
(N
: Node_Id
) return Traverse_Result
is
13671 if Nkind
(N
) = N_Attribute_Reference
13672 and then Attribute_Name
(N
) = Name_Loop_Entry
13674 Has_Loop_Entry
:= True;
13681 procedure Traverse
is new Traverse_Proc
(Process
);
13683 -- Start of processing for Contains_Loop_Entry
13687 return Has_Loop_Entry
;
13688 end Contains_Loop_Entry
;
13693 New_Args
: List_Id
;
13695 -- Start of processing for Assert
13698 -- Assert is an Ada 2005 RM-defined pragma
13700 if Prag_Id
= Pragma_Assert
then
13703 -- The remaining ones are GNAT pragmas
13709 Check_At_Least_N_Arguments
(1);
13710 Check_At_Most_N_Arguments
(2);
13711 Check_Arg_Order
((Name_Check
, Name_Message
));
13712 Check_Optional_Identifier
(Arg1
, Name_Check
);
13713 Expr
:= Get_Pragma_Arg
(Arg1
);
13715 -- Special processing for Loop_Invariant, Loop_Variant or for
13716 -- other cases where a Loop_Entry attribute is present. If the
13717 -- assertion pragma contains attribute Loop_Entry, ensure that
13718 -- the related pragma is within a loop.
13720 if Prag_Id
= Pragma_Loop_Invariant
13721 or else Prag_Id
= Pragma_Loop_Variant
13722 or else Contains_Loop_Entry
(Expr
)
13724 Check_Loop_Pragma_Placement
;
13726 -- Perform preanalysis to deal with embedded Loop_Entry
13729 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13732 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13733 -- a corresponding Check pragma:
13735 -- pragma Check (name, condition [, msg]);
13737 -- Where name is the identifier matching the pragma name. So
13738 -- rewrite pragma in this manner, transfer the message argument
13739 -- if present, and analyze the result
13741 -- Note: When dealing with a semantically analyzed tree, the
13742 -- information that a Check node N corresponds to a source Assert,
13743 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13744 -- pragma kind of Original_Node(N).
13746 New_Args
:= New_List
(
13747 Make_Pragma_Argument_Association
(Loc
,
13748 Expression
=> Make_Identifier
(Loc
, Pname
)),
13749 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13750 Expression
=> Expr
));
13752 if Arg_Count
> 1 then
13753 Check_Optional_Identifier
(Arg2
, Name_Message
);
13755 -- Provide semantic annotations for optional argument, for
13756 -- ASIS use, before rewriting.
13757 -- Is this still needed???
13759 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13760 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13763 -- Rewrite as Check pragma
13767 Chars
=> Name_Check
,
13768 Pragma_Argument_Associations
=> New_Args
));
13773 ----------------------
13774 -- Assertion_Policy --
13775 ----------------------
13777 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13779 -- The following form is Ada 2012 only, but we allow it in all modes
13781 -- Pragma Assertion_Policy (
13782 -- ASSERTION_KIND => POLICY_IDENTIFIER
13783 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13785 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13787 -- RM_ASSERTION_KIND ::= Assert |
13788 -- Static_Predicate |
13789 -- Dynamic_Predicate |
13794 -- Type_Invariant |
13795 -- Type_Invariant'Class |
13796 -- Default_Initial_Condition
13798 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13800 -- Contract_Cases |
13803 -- Initial_Condition |
13804 -- Loop_Invariant |
13810 -- Statement_Assertions |
13811 -- Subprogram_Variant
13813 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13814 -- ID_ASSERTION_KIND list contains implementation-defined additions
13815 -- recognized by GNAT. The effect is to control the behavior of
13816 -- identically named aspects and pragmas, depending on the specified
13817 -- policy identifier:
13819 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13821 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13822 -- implementation-defined addition that results in totally ignoring
13823 -- the corresponding assertion. If Disable is specified, then the
13824 -- argument of the assertion is not even analyzed. This is useful
13825 -- when the aspect/pragma argument references entities in a with'ed
13826 -- package that is replaced by a dummy package in the final build.
13828 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13829 -- and Type_Invariant'Class were recognized by the parser and
13830 -- transformed into references to the special internal identifiers
13831 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13832 -- processing is required here.
13834 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13835 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13836 -- Converts the assertion policy 'Suppressible' to either Check or
13837 -- Ignore based on whether checks are suppressed via -gnatp.
13839 --------------------------
13840 -- Resolve_Suppressible --
13841 --------------------------
13843 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13844 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13848 -- Transform policy argument Suppressible into either Ignore or
13849 -- Check depending on whether checks are enabled or suppressed.
13851 if Chars
(Arg
) = Name_Suppressible
then
13852 if Suppress_Checks
then
13853 Nam
:= Name_Ignore
;
13858 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13860 end Resolve_Suppressible
;
13872 -- This can always appear as a configuration pragma
13874 if Is_Configuration_Pragma
then
13877 -- It can also appear in a declarative part or package spec in Ada
13878 -- 2012 mode. We allow this in other modes, but in that case we
13879 -- consider that we have an Ada 2012 pragma on our hands.
13882 Check_Is_In_Decl_Part_Or_Package_Spec
;
13886 -- One argument case with no identifier (first form above)
13889 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13890 or else Chars
(Arg1
) = No_Name
)
13892 Check_Arg_Is_One_Of
(Arg1
,
13893 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13895 Resolve_Suppressible
(Arg1
);
13897 -- Treat one argument Assertion_Policy as equivalent to:
13899 -- pragma Check_Policy (Assertion, policy)
13901 -- So rewrite pragma in that manner and link on to the chain
13902 -- of Check_Policy pragmas, marking the pragma as analyzed.
13904 Policy
:= Get_Pragma_Arg
(Arg1
);
13908 Chars
=> Name_Check_Policy
,
13909 Pragma_Argument_Associations
=> New_List
(
13910 Make_Pragma_Argument_Association
(Loc
,
13911 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13913 Make_Pragma_Argument_Association
(Loc
,
13915 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13918 -- Here if we have two or more arguments
13921 Check_At_Least_N_Arguments
(1);
13924 -- Loop through arguments
13927 while Present
(Arg
) loop
13928 LocP
:= Sloc
(Arg
);
13930 -- Kind must be specified
13932 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13933 or else Chars
(Arg
) = No_Name
13936 ("missing assertion kind for pragma%", Arg
);
13939 -- Check Kind and Policy have allowed forms
13941 Kind
:= Chars
(Arg
);
13942 Policy
:= Get_Pragma_Arg
(Arg
);
13944 if not Is_Valid_Assertion_Kind
(Kind
) then
13946 ("invalid assertion kind for pragma%", Arg
);
13949 Check_Arg_Is_One_Of
(Arg
,
13950 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13952 Resolve_Suppressible
(Arg
);
13954 if Kind
= Name_Ghost
then
13956 -- The Ghost policy must be either Check or Ignore
13957 -- (SPARK RM 6.9(6)).
13959 if Chars
(Policy
) not in Name_Check | Name_Ignore
then
13961 ("argument of pragma % Ghost must be Check or "
13962 & "Ignore", Policy
);
13965 -- Pragma Assertion_Policy specifying a Ghost policy
13966 -- cannot occur within a Ghost subprogram or package
13967 -- (SPARK RM 6.9(14)).
13969 if Ghost_Mode
> None
then
13971 ("pragma % cannot appear within ghost subprogram or "
13976 -- Rewrite the Assertion_Policy pragma as a series of
13977 -- Check_Policy pragmas of the form:
13979 -- Check_Policy (Kind, Policy);
13981 -- Note: the insertion of the pragmas cannot be done with
13982 -- Insert_Action because in the configuration case, there
13983 -- are no scopes on the scope stack and the mechanism will
13986 Insert_Before_And_Analyze
(N
,
13988 Chars
=> Name_Check_Policy
,
13989 Pragma_Argument_Associations
=> New_List
(
13990 Make_Pragma_Argument_Association
(LocP
,
13991 Expression
=> Make_Identifier
(LocP
, Kind
)),
13992 Make_Pragma_Argument_Association
(LocP
,
13993 Expression
=> Policy
))));
13998 -- Rewrite the Assertion_Policy pragma as null since we have
13999 -- now inserted all the equivalent Check pragmas.
14001 Rewrite
(N
, Make_Null_Statement
(Loc
));
14004 end Assertion_Policy
;
14006 ------------------------------
14007 -- Assume_No_Invalid_Values --
14008 ------------------------------
14010 -- pragma Assume_No_Invalid_Values (On | Off);
14012 when Pragma_Assume_No_Invalid_Values
=>
14014 Check_Valid_Configuration_Pragma
;
14015 Check_Arg_Count
(1);
14016 Check_No_Identifiers
;
14017 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14019 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14020 Assume_No_Invalid_Values
:= True;
14022 Assume_No_Invalid_Values
:= False;
14025 --------------------------
14026 -- Attribute_Definition --
14027 --------------------------
14029 -- pragma Attribute_Definition
14030 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
14031 -- [Entity =>] LOCAL_NAME,
14032 -- [Expression =>] EXPRESSION | NAME);
14034 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
14035 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
14040 Check_Arg_Count
(3);
14041 Check_Optional_Identifier
(Arg1
, "attribute");
14042 Check_Optional_Identifier
(Arg2
, "entity");
14043 Check_Optional_Identifier
(Arg3
, "expression");
14045 if Nkind
(Attribute_Designator
) /= N_Identifier
then
14046 Error_Msg_N
("attribute name expected", Attribute_Designator
);
14050 Check_Arg_Is_Local_Name
(Arg2
);
14052 -- If the attribute is not recognized, then issue a warning (not
14053 -- an error), and ignore the pragma.
14055 Aname
:= Chars
(Attribute_Designator
);
14057 if not Is_Attribute_Name
(Aname
) then
14058 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
14062 -- Otherwise, rewrite the pragma as an attribute definition clause
14065 Make_Attribute_Definition_Clause
(Loc
,
14066 Name
=> Get_Pragma_Arg
(Arg2
),
14068 Expression
=> Get_Pragma_Arg
(Arg3
)));
14070 end Attribute_Definition
;
14072 ------------------------------------------------------------------
14073 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
14075 ------------------------------------------------------------------
14077 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
14078 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
14079 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
14080 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
14081 -- pragma No_Caching [ (boolean_EXPRESSION) ];
14083 when Pragma_Async_Readers
14084 | Pragma_Async_Writers
14085 | Pragma_Effective_Reads
14086 | Pragma_Effective_Writes
14087 | Pragma_No_Caching
14089 Async_Effective
: declare
14090 Obj_Or_Type_Decl
: Node_Id
;
14091 Obj_Or_Type_Id
: Entity_Id
;
14094 Check_No_Identifiers
;
14095 Check_At_Most_N_Arguments
(1);
14097 Obj_Or_Type_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14099 -- Pragma must apply to a object declaration or to a type
14100 -- declaration. Original_Node is necessary to account for
14101 -- untagged derived types that are rewritten as subtypes of
14102 -- their respective root types.
14104 if Nkind
(Obj_Or_Type_Decl
) /= N_Object_Declaration
14105 and then Nkind
(Original_Node
(Obj_Or_Type_Decl
)) not in
14106 N_Full_Type_Declaration |
14107 N_Private_Type_Declaration |
14108 N_Formal_Type_Declaration |
14109 N_Task_Type_Declaration |
14110 N_Protected_Type_Declaration
14115 Obj_Or_Type_Id
:= Defining_Entity
(Obj_Or_Type_Decl
);
14117 -- Perform minimal verification to ensure that the argument is at
14118 -- least an object or a type. Subsequent finer grained checks will
14119 -- be done at the end of the declarative region that contains the
14122 if Ekind
(Obj_Or_Type_Id
) in E_Constant | E_Variable
14123 or else Is_Type
(Obj_Or_Type_Id
)
14126 -- In the case of a type, pragma is a type-related
14127 -- representation item and so requires checks common to
14128 -- all type-related representation items.
14130 if Is_Type
(Obj_Or_Type_Id
)
14131 and then Rep_Item_Too_Late
(Obj_Or_Type_Id
, N
)
14136 -- A pragma that applies to a Ghost entity becomes Ghost for
14137 -- the purposes of legality checks and removal of ignored Ghost
14140 Mark_Ghost_Pragma
(N
, Obj_Or_Type_Id
);
14142 -- Chain the pragma on the contract for further processing by
14143 -- Analyze_External_Property_In_Decl_Part.
14145 Add_Contract_Item
(N
, Obj_Or_Type_Id
);
14147 -- Analyze the Boolean expression (if any)
14149 if Present
(Arg1
) then
14150 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14153 -- Otherwise the external property applies to a constant
14157 ("pragma % must apply to a volatile type or object");
14159 end Async_Effective
;
14165 -- pragma Asynchronous (LOCAL_NAME);
14167 when Pragma_Asynchronous
=> Asynchronous
: declare
14170 Formal
: Entity_Id
;
14175 procedure Process_Async_Pragma
;
14176 -- Common processing for procedure and access-to-procedure case
14178 --------------------------
14179 -- Process_Async_Pragma --
14180 --------------------------
14182 procedure Process_Async_Pragma
is
14185 Set_Is_Asynchronous
(Nm
);
14189 -- The formals should be of mode IN (RM E.4.1(6))
14192 while Present
(S
) loop
14193 Formal
:= Defining_Identifier
(S
);
14195 if Nkind
(Formal
) = N_Defining_Identifier
14196 and then Ekind
(Formal
) /= E_In_Parameter
14199 ("pragma% procedure can only have IN parameter",
14206 Set_Is_Asynchronous
(Nm
);
14207 end Process_Async_Pragma
;
14209 -- Start of processing for pragma Asynchronous
14212 Check_Ada_83_Warning
;
14213 Check_No_Identifiers
;
14214 Check_Arg_Count
(1);
14215 Check_Arg_Is_Local_Name
(Arg1
);
14217 if Debug_Flag_U
then
14221 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14222 Analyze
(Get_Pragma_Arg
(Arg1
));
14223 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
14225 -- A pragma that applies to a Ghost entity becomes Ghost for the
14226 -- purposes of legality checks and removal of ignored Ghost code.
14228 Mark_Ghost_Pragma
(N
, Nm
);
14230 if not Is_Remote_Call_Interface
(C_Ent
)
14231 and then not Is_Remote_Types
(C_Ent
)
14233 -- This pragma should only appear in an RCI or Remote Types
14234 -- unit (RM E.4.1(4)).
14237 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
14240 if Ekind
(Nm
) = E_Procedure
14241 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
14243 if not Is_Remote_Call_Interface
(Nm
) then
14245 ("pragma% cannot be applied on non-remote procedure",
14249 L
:= Parameter_Specifications
(Parent
(Nm
));
14250 Process_Async_Pragma
;
14253 elsif Ekind
(Nm
) = E_Function
then
14255 ("pragma% cannot be applied to function", Arg1
);
14257 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
14258 if Is_Record_Type
(Nm
) then
14260 -- A record type that is the Equivalent_Type for a remote
14261 -- access-to-subprogram type.
14263 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
14266 -- A non-expanded RAS type (distribution is not enabled)
14268 Decl
:= Declaration_Node
(Nm
);
14271 if Nkind
(Decl
) = N_Full_Type_Declaration
14272 and then Nkind
(Type_Definition
(Decl
)) =
14273 N_Access_Procedure_Definition
14275 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
14276 Process_Async_Pragma
;
14278 if Is_Asynchronous
(Nm
)
14279 and then Expander_Active
14280 and then Get_PCS_Name
/= Name_No_DSA
14282 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
14287 ("pragma% cannot reference access-to-function type",
14291 -- Only other possibility is access-to-class-wide type
14293 elsif Is_Access_Type
(Nm
)
14294 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
14296 Check_First_Subtype
(Arg1
);
14297 Set_Is_Asynchronous
(Nm
);
14298 if Expander_Active
then
14299 RACW_Type_Is_Asynchronous
(Nm
);
14303 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
14311 -- pragma Atomic (LOCAL_NAME);
14313 when Pragma_Atomic
=>
14314 Process_Atomic_Independent_Shared_Volatile
;
14316 -----------------------
14317 -- Atomic_Components --
14318 -----------------------
14320 -- pragma Atomic_Components (array_LOCAL_NAME);
14322 -- This processing is shared by Volatile_Components
14324 when Pragma_Atomic_Components
14325 | Pragma_Volatile_Components
14327 Atomic_Components
: declare
14333 Check_Ada_83_Warning
;
14334 Check_No_Identifiers
;
14335 Check_Arg_Count
(1);
14336 Check_Arg_Is_Local_Name
(Arg1
);
14337 E_Id
:= Get_Pragma_Arg
(Arg1
);
14339 if Etype
(E_Id
) = Any_Type
then
14343 E
:= Entity
(E_Id
);
14345 -- A pragma that applies to a Ghost entity becomes Ghost for the
14346 -- purposes of legality checks and removal of ignored Ghost code.
14348 Mark_Ghost_Pragma
(N
, E
);
14349 Check_Duplicate_Pragma
(E
);
14351 if Rep_Item_Too_Early
(E
, N
)
14353 Rep_Item_Too_Late
(E
, N
)
14358 D
:= Declaration_Node
(E
);
14360 if (Nkind
(D
) = N_Full_Type_Declaration
and then Is_Array_Type
(E
))
14362 (Nkind
(D
) = N_Object_Declaration
14363 and then Ekind
(E
) in E_Constant | E_Variable
14364 and then Nkind
(Object_Definition
(D
)) =
14365 N_Constrained_Array_Definition
)
14367 (Ada_Version
>= Ada_2022
14368 and then Nkind
(D
) = N_Formal_Type_Declaration
)
14370 -- The flag is set on the base type, or on the object
14372 if Nkind
(D
) = N_Full_Type_Declaration
then
14373 E
:= Base_Type
(E
);
14376 -- Atomic implies both Independent and Volatile
14378 if Prag_Id
= Pragma_Atomic_Components
then
14379 Set_Has_Atomic_Components
(E
);
14380 Set_Has_Independent_Components
(E
);
14383 Set_Has_Volatile_Components
(E
);
14386 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
14388 end Atomic_Components
;
14390 --------------------
14391 -- Attach_Handler --
14392 --------------------
14394 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
14396 when Pragma_Attach_Handler
=>
14397 Check_Ada_83_Warning
;
14398 Check_No_Identifiers
;
14399 Check_Arg_Count
(2);
14401 if No_Run_Time_Mode
then
14402 Error_Msg_CRT
("Attach_Handler pragma", N
);
14404 Check_Interrupt_Or_Attach_Handler
;
14406 -- The expression that designates the attribute may depend on a
14407 -- discriminant, and is therefore a per-object expression, to
14408 -- be expanded in the init proc. If expansion is enabled, then
14409 -- perform semantic checks on a copy only.
14414 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
14417 -- In Relaxed_RM_Semantics mode, we allow any static
14418 -- integer value, for compatibility with other compilers.
14420 if Relaxed_RM_Semantics
14421 and then Nkind
(Parg2
) = N_Integer_Literal
14423 Typ
:= Standard_Integer
;
14425 Typ
:= RTE
(RE_Interrupt_ID
);
14428 if Expander_Active
then
14429 Temp
:= New_Copy_Tree
(Parg2
);
14430 Set_Parent
(Temp
, N
);
14431 Preanalyze_And_Resolve
(Temp
, Typ
);
14434 Resolve
(Parg2
, Typ
);
14438 Process_Interrupt_Or_Attach_Handler
;
14441 --------------------
14442 -- C_Pass_By_Copy --
14443 --------------------
14445 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
14447 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
14453 Check_Valid_Configuration_Pragma
;
14454 Check_Arg_Count
(1);
14455 Check_Optional_Identifier
(Arg1
, "max_size");
14457 Arg
:= Get_Pragma_Arg
(Arg1
);
14458 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
14460 Val
:= Expr_Value
(Arg
);
14464 ("maximum size for pragma% must be positive", Arg1
);
14466 elsif UI_Is_In_Int_Range
(Val
) then
14467 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
14469 -- If a giant value is given, Int'Last will do well enough.
14470 -- If sometime someone complains that a record larger than
14471 -- two gigabytes is not copied, we will worry about it then.
14474 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
14476 end C_Pass_By_Copy
;
14482 -- pragma Check ([Name =>] CHECK_KIND,
14483 -- [Check =>] Boolean_EXPRESSION
14484 -- [,[Message =>] String_EXPRESSION]);
14486 -- CHECK_KIND ::= IDENTIFIER |
14489 -- Invariant'Class |
14490 -- Type_Invariant'Class
14492 -- The identifiers Assertions and Statement_Assertions are not
14493 -- allowed, since they have special meaning for Check_Policy.
14495 -- WARNING: The code below manages Ghost regions. Return statements
14496 -- must be replaced by gotos which jump to the end of the code and
14497 -- restore the Ghost mode.
14499 when Pragma_Check
=> Check
: declare
14500 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
14501 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
14502 -- Save the Ghost-related attributes to restore on exit
14508 pragma Warnings
(Off
, Str
);
14511 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
14512 -- the mode now to ensure that any nodes generated during analysis
14513 -- and expansion are marked as Ghost.
14515 Set_Ghost_Mode
(N
);
14518 Check_At_Least_N_Arguments
(2);
14519 Check_At_Most_N_Arguments
(3);
14520 Check_Optional_Identifier
(Arg1
, Name_Name
);
14521 Check_Optional_Identifier
(Arg2
, Name_Check
);
14523 if Arg_Count
= 3 then
14524 Check_Optional_Identifier
(Arg3
, Name_Message
);
14525 Str
:= Get_Pragma_Arg
(Arg3
);
14528 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
14529 Check_Arg_Is_Identifier
(Arg1
);
14530 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
14532 -- Check forbidden name Assertions or Statement_Assertions
14535 when Name_Assertions
=>
14537 ("""Assertions"" is not allowed as a check kind for "
14538 & "pragma%", Arg1
);
14540 when Name_Statement_Assertions
=>
14542 ("""Statement_Assertions"" is not allowed as a check kind "
14543 & "for pragma%", Arg1
);
14549 -- Check applicable policy. We skip this if Checked/Ignored status
14550 -- is already set (e.g. in the case of a pragma from an aspect).
14552 if Is_Checked
(N
) or else Is_Ignored
(N
) then
14555 -- For a non-source pragma that is a rewriting of another pragma,
14556 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14558 elsif Is_Rewrite_Substitution
(N
)
14559 and then Nkind
(Original_Node
(N
)) = N_Pragma
14561 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
14562 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
14564 -- Otherwise query the applicable policy at this point
14567 case Check_Kind
(Cname
) is
14568 when Name_Ignore
=>
14569 Set_Is_Ignored
(N
, True);
14570 Set_Is_Checked
(N
, False);
14573 Set_Is_Ignored
(N
, False);
14574 Set_Is_Checked
(N
, True);
14576 -- For disable, rewrite pragma as null statement and skip
14577 -- rest of the analysis of the pragma.
14579 when Name_Disable
=>
14580 Rewrite
(N
, Make_Null_Statement
(Loc
));
14584 -- No other possibilities
14587 raise Program_Error
;
14591 -- If check kind was not Disable, then continue pragma analysis
14593 Expr
:= Get_Pragma_Arg
(Arg2
);
14595 -- Mark the pragma (or, if rewritten from an aspect, the original
14596 -- aspect) as enabled. Nothing to do for an internally generated
14597 -- check for a dynamic predicate.
14600 and then not Split_PPC
(N
)
14601 and then Cname
/= Name_Dynamic_Predicate
14603 Set_SCO_Pragma_Enabled
(Loc
);
14606 -- Deal with analyzing the string argument. If checks are not
14607 -- on we don't want any expansion (since such expansion would
14608 -- not get properly deleted) but we do want to analyze (to get
14609 -- proper references). The Preanalyze_And_Resolve routine does
14610 -- just what we want. Ditto if pragma is active, because it will
14611 -- be rewritten as an if-statement whose analysis will complete
14612 -- analysis and expansion of the string message. This makes a
14613 -- difference in the unusual case where the expression for the
14614 -- string may have a side effect, such as raising an exception.
14615 -- This is mandated by RM 11.4.2, which specifies that the string
14616 -- expression is only evaluated if the check fails and
14617 -- Assertion_Error is to be raised.
14619 if Arg_Count
= 3 then
14620 Preanalyze_And_Resolve
(Str
, Standard_String
);
14623 -- Now you might think we could just do the same with the Boolean
14624 -- expression if checks are off (and expansion is on) and then
14625 -- rewrite the check as a null statement. This would work but we
14626 -- would lose the useful warnings about an assertion being bound
14627 -- to fail even if assertions are turned off.
14629 -- So instead we wrap the boolean expression in an if statement
14630 -- that looks like:
14632 -- if False and then condition then
14636 -- The reason we do this rewriting during semantic analysis rather
14637 -- than as part of normal expansion is that we cannot analyze and
14638 -- expand the code for the boolean expression directly, or it may
14639 -- cause insertion of actions that would escape the attempt to
14640 -- suppress the check code.
14642 -- Note that the Sloc for the if statement corresponds to the
14643 -- argument condition, not the pragma itself. The reason for
14644 -- this is that we may generate a warning if the condition is
14645 -- False at compile time, and we do not want to delete this
14646 -- warning when we delete the if statement.
14648 if Expander_Active
and Is_Ignored
(N
) then
14649 Eloc
:= Sloc
(Expr
);
14652 Make_If_Statement
(Eloc
,
14654 Make_And_Then
(Eloc
,
14655 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14656 Right_Opnd
=> Expr
),
14657 Then_Statements
=> New_List
(
14658 Make_Null_Statement
(Eloc
))));
14660 -- Now go ahead and analyze the if statement
14662 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14664 -- One rather special treatment. If we are now in Eliminated
14665 -- overflow mode, then suppress overflow checking since we do
14666 -- not want to drag in the bignum stuff if we are in Ignore
14667 -- mode anyway. This is particularly important if we are using
14668 -- a configurable run time that does not support bignum ops.
14670 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14672 Svo
: constant Boolean :=
14673 Scope_Suppress
.Suppress
(Overflow_Check
);
14675 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14676 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14678 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14679 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14682 -- Not that special case
14688 -- All done with this check
14690 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14692 -- Check is active or expansion not active. In these cases we can
14693 -- just go ahead and analyze the boolean with no worries.
14696 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14697 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14698 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14701 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14704 --------------------------
14705 -- Check_Float_Overflow --
14706 --------------------------
14708 -- pragma Check_Float_Overflow;
14710 when Pragma_Check_Float_Overflow
=>
14712 Check_Valid_Configuration_Pragma
;
14713 Check_Arg_Count
(0);
14714 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14720 -- pragma Check_Name (check_IDENTIFIER);
14722 when Pragma_Check_Name
=>
14724 Check_No_Identifiers
;
14725 Check_Valid_Configuration_Pragma
;
14726 Check_Arg_Count
(1);
14727 Check_Arg_Is_Identifier
(Arg1
);
14730 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14733 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14734 if Check_Names
.Table
(J
) = Nam
then
14739 Check_Names
.Append
(Nam
);
14746 -- This is the old style syntax, which is still allowed in all modes:
14748 -- pragma Check_Policy ([Name =>] CHECK_KIND
14749 -- [Policy =>] POLICY_IDENTIFIER);
14751 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14753 -- CHECK_KIND ::= IDENTIFIER |
14756 -- Type_Invariant'Class |
14759 -- This is the new style syntax, compatible with Assertion_Policy
14760 -- and also allowed in all modes.
14762 -- Pragma Check_Policy (
14763 -- CHECK_KIND => POLICY_IDENTIFIER
14764 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14766 -- Note: the identifiers Name and Policy are not allowed as
14767 -- Check_Kind values. This avoids ambiguities between the old and
14768 -- new form syntax.
14770 when Pragma_Check_Policy
=> Check_Policy
: declare
14775 Check_At_Least_N_Arguments
(1);
14777 -- A Check_Policy pragma can appear either as a configuration
14778 -- pragma, or in a declarative part or a package spec (see RM
14779 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14780 -- followed for Check_Policy).
14782 if not Is_Configuration_Pragma
then
14783 Check_Is_In_Decl_Part_Or_Package_Spec
;
14786 -- Figure out if we have the old or new syntax. We have the
14787 -- old syntax if the first argument has no identifier, or the
14788 -- identifier is Name.
14790 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14791 or else Chars
(Arg1
) in No_Name | Name_Name
14795 Check_Arg_Count
(2);
14796 Check_Optional_Identifier
(Arg1
, Name_Name
);
14797 Kind
:= Get_Pragma_Arg
(Arg1
);
14798 Rewrite_Assertion_Kind
(Kind
,
14799 From_Policy
=> Comes_From_Source
(N
));
14800 Check_Arg_Is_Identifier
(Arg1
);
14802 -- Check forbidden check kind
14804 if Chars
(Kind
) in Name_Name | Name_Policy
then
14805 Error_Msg_Name_2
:= Chars
(Kind
);
14807 ("pragma% does not allow% as check name", Arg1
);
14812 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14813 Check_Arg_Is_One_Of
14815 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14817 -- And chain pragma on the Check_Policy_List for search
14819 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14820 Opt
.Check_Policy_List
:= N
;
14822 -- For the new syntax, what we do is to convert each argument to
14823 -- an old syntax equivalent. We do that because we want to chain
14824 -- old style Check_Policy pragmas for the search (we don't want
14825 -- to have to deal with multiple arguments in the search).
14836 while Present
(Arg
) loop
14837 LocP
:= Sloc
(Arg
);
14838 Argx
:= Get_Pragma_Arg
(Arg
);
14840 -- Kind must be specified
14842 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14843 or else Chars
(Arg
) = No_Name
14846 ("missing assertion kind for pragma%", Arg
);
14849 -- Construct equivalent old form syntax Check_Policy
14850 -- pragma and insert it to get remaining checks.
14854 Chars
=> Name_Check_Policy
,
14855 Pragma_Argument_Associations
=> New_List
(
14856 Make_Pragma_Argument_Association
(LocP
,
14858 Make_Identifier
(LocP
, Chars
(Arg
))),
14859 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14860 Expression
=> Argx
)));
14864 -- For a configuration pragma, insert old form in
14865 -- the corresponding file.
14867 if Is_Configuration_Pragma
then
14868 Insert_After
(N
, New_P
);
14872 Insert_Action
(N
, New_P
);
14876 -- Rewrite original Check_Policy pragma to null, since we
14877 -- have converted it into a series of old syntax pragmas.
14879 Rewrite
(N
, Make_Null_Statement
(Loc
));
14889 -- pragma Comment (static_string_EXPRESSION)
14891 -- Processing for pragma Comment shares the circuitry for pragma
14892 -- Ident. The only differences are that Ident enforces a limit of 31
14893 -- characters on its argument, and also enforces limitations on
14894 -- placement for DEC compatibility. Pragma Comment shares neither of
14895 -- these restrictions.
14897 -------------------
14898 -- Common_Object --
14899 -------------------
14901 -- pragma Common_Object (
14902 -- [Internal =>] LOCAL_NAME
14903 -- [, [External =>] EXTERNAL_SYMBOL]
14904 -- [, [Size =>] EXTERNAL_SYMBOL]);
14906 -- Processing for this pragma is shared with Psect_Object
14908 ----------------------------------------------
14909 -- Compile_Time_Error, Compile_Time_Warning --
14910 ----------------------------------------------
14912 -- pragma Compile_Time_Error
14913 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14915 -- pragma Compile_Time_Warning
14916 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14918 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning
=>
14921 Process_Compile_Time_Warning_Or_Error
;
14923 -----------------------------
14924 -- Complete_Representation --
14925 -----------------------------
14927 -- pragma Complete_Representation;
14929 when Pragma_Complete_Representation
=>
14931 Check_Arg_Count
(0);
14933 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14935 ("pragma & must appear within record representation clause");
14938 ----------------------------
14939 -- Complex_Representation --
14940 ----------------------------
14942 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14944 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14951 Check_Arg_Count
(1);
14952 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14953 Check_Arg_Is_Local_Name
(Arg1
);
14954 E_Id
:= Get_Pragma_Arg
(Arg1
);
14956 if Etype
(E_Id
) = Any_Type
then
14960 E
:= Entity
(E_Id
);
14962 if not Is_Record_Type
(E
) then
14964 ("argument for pragma% must be record type", Arg1
);
14967 Ent
:= First_Entity
(E
);
14970 or else No
(Next_Entity
(Ent
))
14971 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14972 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14973 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14976 ("record for pragma% must have two fields of the same "
14977 & "floating-point type", Arg1
);
14980 Set_Has_Complex_Representation
(Base_Type
(E
));
14982 -- We need to treat the type has having a non-standard
14983 -- representation, for back-end purposes, even though in
14984 -- general a complex will have the default representation
14985 -- of a record with two real components.
14987 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14989 end Complex_Representation
;
14991 -------------------------
14992 -- Component_Alignment --
14993 -------------------------
14995 -- pragma Component_Alignment (
14996 -- [Form =>] ALIGNMENT_CHOICE
14997 -- [, [Name =>] type_LOCAL_NAME]);
14999 -- ALIGNMENT_CHOICE ::=
15001 -- | Component_Size_4
15005 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
15006 Args
: Args_List
(1 .. 2);
15007 Names
: constant Name_List
(1 .. 2) := (
15011 Form
: Node_Id
renames Args
(1);
15012 Name
: Node_Id
renames Args
(2);
15014 Atype
: Component_Alignment_Kind
;
15019 Gather_Associations
(Names
, Args
);
15022 Error_Pragma
("missing Form argument for pragma%");
15025 Check_Arg_Is_Identifier
(Form
);
15027 -- Get proper alignment, note that Default = Component_Size on all
15028 -- machines we have so far, and we want to set this value rather
15029 -- than the default value to indicate that it has been explicitly
15030 -- set (and thus will not get overridden by the default component
15031 -- alignment for the current scope)
15033 if Chars
(Form
) = Name_Component_Size
then
15034 Atype
:= Calign_Component_Size
;
15036 elsif Chars
(Form
) = Name_Component_Size_4
then
15037 Atype
:= Calign_Component_Size_4
;
15039 elsif Chars
(Form
) = Name_Default
then
15040 Atype
:= Calign_Component_Size
;
15042 elsif Chars
(Form
) = Name_Storage_Unit
then
15043 Atype
:= Calign_Storage_Unit
;
15047 ("invalid Form parameter for pragma%", Form
);
15050 -- The pragma appears in a configuration file
15052 if No
(Parent
(N
)) then
15053 Check_Valid_Configuration_Pragma
;
15055 -- Capture the component alignment in a global variable when
15056 -- the pragma appears in a configuration file. Note that the
15057 -- scope stack is empty at this point and cannot be used to
15058 -- store the alignment value.
15060 Configuration_Component_Alignment
:= Atype
;
15062 -- Case with no name, supplied, affects scope table entry
15064 elsif No
(Name
) then
15066 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
15068 -- Case of name supplied
15071 Check_Arg_Is_Local_Name
(Name
);
15073 Typ
:= Entity
(Name
);
15076 or else Rep_Item_Too_Early
(Typ
, N
)
15080 Typ
:= Underlying_Type
(Typ
);
15083 if not Is_Record_Type
(Typ
)
15084 and then not Is_Array_Type
(Typ
)
15087 ("Name parameter of pragma% must identify record or "
15088 & "array type", Name
);
15091 -- An explicit Component_Alignment pragma overrides an
15092 -- implicit pragma Pack, but not an explicit one.
15094 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
15095 Set_Is_Packed
(Base_Type
(Typ
), False);
15096 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
15099 end Component_AlignmentP
;
15101 --------------------------------
15102 -- Constant_After_Elaboration --
15103 --------------------------------
15105 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
15107 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
15109 Obj_Decl
: Node_Id
;
15110 Obj_Id
: Entity_Id
;
15114 Check_No_Identifiers
;
15115 Check_At_Most_N_Arguments
(1);
15117 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
15119 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
15123 Obj_Id
:= Defining_Entity
(Obj_Decl
);
15125 -- The object declaration must be a library-level variable which
15126 -- is either explicitly initialized or obtains a value during the
15127 -- elaboration of a package body (SPARK RM 3.3.1).
15129 if Ekind
(Obj_Id
) = E_Variable
then
15130 if not Is_Library_Level_Entity
(Obj_Id
) then
15132 ("pragma % must apply to a library level variable");
15135 -- Otherwise the pragma applies to a constant, which is illegal
15138 Error_Pragma
("pragma % must apply to a variable declaration");
15141 -- A pragma that applies to a Ghost entity becomes Ghost for the
15142 -- purposes of legality checks and removal of ignored Ghost code.
15144 Mark_Ghost_Pragma
(N
, Obj_Id
);
15146 -- Chain the pragma on the contract for completeness
15148 Add_Contract_Item
(N
, Obj_Id
);
15150 -- Analyze the Boolean expression (if any)
15152 if Present
(Arg1
) then
15153 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
15155 end Constant_After_Elaboration
;
15157 --------------------
15158 -- Contract_Cases --
15159 --------------------
15161 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
15163 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
15165 -- CASE_GUARD ::= boolean_EXPRESSION | others
15167 -- CONSEQUENCE ::= boolean_EXPRESSION
15169 -- Characteristics:
15171 -- * Analysis - The annotation undergoes initial checks to verify
15172 -- the legal placement and context. Secondary checks preanalyze the
15175 -- Analyze_Contract_Cases_In_Decl_Part
15177 -- * Expansion - The annotation is expanded during the expansion of
15178 -- the related subprogram [body] contract as performed in:
15180 -- Expand_Subprogram_Contract
15182 -- * Template - The annotation utilizes the generic template of the
15183 -- related subprogram [body] when it is:
15185 -- aspect on subprogram declaration
15186 -- aspect on stand-alone subprogram body
15187 -- pragma on stand-alone subprogram body
15189 -- The annotation must prepare its own template when it is:
15191 -- pragma on subprogram declaration
15193 -- * Globals - Capture of global references must occur after full
15196 -- * Instance - The annotation is instantiated automatically when
15197 -- the related generic subprogram [body] is instantiated except for
15198 -- the "pragma on subprogram declaration" case. In that scenario
15199 -- the annotation must instantiate itself.
15201 when Pragma_Contract_Cases
=> Contract_Cases
: declare
15202 Spec_Id
: Entity_Id
;
15203 Subp_Decl
: Node_Id
;
15204 Subp_Spec
: Node_Id
;
15208 Check_No_Identifiers
;
15209 Check_Arg_Count
(1);
15211 -- Ensure the proper placement of the pragma. Contract_Cases must
15212 -- be associated with a subprogram declaration or a body that acts
15216 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15220 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
15223 -- Generic subprogram
15225 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15228 -- Body acts as spec
15230 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15231 and then No
(Corresponding_Spec
(Subp_Decl
))
15235 -- Body stub acts as spec
15237 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15238 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15244 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15245 Subp_Spec
:= Specification
(Subp_Decl
);
15247 -- Pragma Contract_Cases is forbidden on null procedures, as
15248 -- this may lead to potential ambiguities in behavior when
15249 -- interface null procedures are involved.
15251 if Nkind
(Subp_Spec
) = N_Procedure_Specification
15252 and then Null_Present
(Subp_Spec
)
15254 Error_Msg_N
(Fix_Error
15255 ("pragma % cannot apply to null procedure"), N
);
15263 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15265 -- A pragma that applies to a Ghost entity becomes Ghost for the
15266 -- purposes of legality checks and removal of ignored Ghost code.
15268 Mark_Ghost_Pragma
(N
, Spec_Id
);
15269 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
15271 -- Chain the pragma on the contract for further processing by
15272 -- Analyze_Contract_Cases_In_Decl_Part.
15274 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15276 -- Fully analyze the pragma when it appears inside an entry
15277 -- or subprogram body because it cannot benefit from forward
15280 if Nkind
(Subp_Decl
) in N_Entry_Body
15281 | N_Subprogram_Body
15282 | N_Subprogram_Body_Stub
15284 -- The legality checks of pragma Contract_Cases are affected by
15285 -- the SPARK mode in effect and the volatility of the context.
15286 -- Analyze all pragmas in a specific order.
15288 Analyze_If_Present
(Pragma_SPARK_Mode
);
15289 Analyze_If_Present
(Pragma_Volatile_Function
);
15290 Analyze_Contract_Cases_In_Decl_Part
(N
);
15292 end Contract_Cases
;
15298 -- pragma Controlled (first_subtype_LOCAL_NAME);
15300 when Pragma_Controlled
=> Controlled
: declare
15304 Check_No_Identifiers
;
15305 Check_Arg_Count
(1);
15306 Check_Arg_Is_Local_Name
(Arg1
);
15307 Arg
:= Get_Pragma_Arg
(Arg1
);
15309 if not Is_Entity_Name
(Arg
)
15310 or else not Is_Access_Type
(Entity
(Arg
))
15312 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
15314 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
15322 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
15323 -- [Entity =>] LOCAL_NAME);
15325 when Pragma_Convention
=> Convention
: declare
15328 pragma Warnings
(Off
, C
);
15329 pragma Warnings
(Off
, E
);
15332 Check_Arg_Order
((Name_Convention
, Name_Entity
));
15333 Check_Ada_83_Warning
;
15334 Check_Arg_Count
(2);
15335 Process_Convention
(C
, E
);
15337 -- A pragma that applies to a Ghost entity becomes Ghost for the
15338 -- purposes of legality checks and removal of ignored Ghost code.
15340 Mark_Ghost_Pragma
(N
, E
);
15343 ---------------------------
15344 -- Convention_Identifier --
15345 ---------------------------
15347 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
15348 -- [Convention =>] convention_IDENTIFIER);
15350 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
15356 Check_Arg_Order
((Name_Name
, Name_Convention
));
15357 Check_Arg_Count
(2);
15358 Check_Optional_Identifier
(Arg1
, Name_Name
);
15359 Check_Optional_Identifier
(Arg2
, Name_Convention
);
15360 Check_Arg_Is_Identifier
(Arg1
);
15361 Check_Arg_Is_Identifier
(Arg2
);
15362 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
15363 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
15365 if Is_Convention_Name
(Cname
) then
15366 Record_Convention_Identifier
15367 (Idnam
, Get_Convention_Id
(Cname
));
15370 ("second arg for % pragma must be convention", Arg2
);
15372 end Convention_Identifier
;
15378 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
15380 when Pragma_CPP_Class
=>
15383 if Warn_On_Obsolescent_Feature
then
15385 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
15386 & "effect; replace it by pragma import?j?", N
);
15389 Check_Arg_Count
(1);
15393 Chars
=> Name_Import
,
15394 Pragma_Argument_Associations
=> New_List
(
15395 Make_Pragma_Argument_Association
(Loc
,
15396 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
15397 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
15400 ---------------------
15401 -- CPP_Constructor --
15402 ---------------------
15404 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
15405 -- [, [External_Name =>] static_string_EXPRESSION ]
15406 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15408 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
15410 Def_Id
: Entity_Id
;
15411 Tag_Typ
: Entity_Id
;
15415 Check_At_Least_N_Arguments
(1);
15416 Check_At_Most_N_Arguments
(3);
15417 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15418 Check_Arg_Is_Local_Name
(Arg1
);
15420 Id
:= Get_Pragma_Arg
(Arg1
);
15421 Find_Program_Unit_Name
(Id
);
15423 -- If we did not find the name, we are done
15425 if Etype
(Id
) = Any_Type
then
15429 Def_Id
:= Entity
(Id
);
15431 -- Check if already defined as constructor
15433 if Is_Constructor
(Def_Id
) then
15435 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
15439 if Ekind
(Def_Id
) = E_Function
15440 and then (Is_CPP_Class
(Etype
(Def_Id
))
15441 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
15443 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
15445 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
15447 ("'C'P'P constructor must be defined in the scope of "
15448 & "its returned type", Arg1
);
15451 if Arg_Count
>= 2 then
15452 Set_Imported
(Def_Id
);
15453 Set_Is_Public
(Def_Id
);
15454 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
15457 Set_Has_Completion
(Def_Id
);
15458 Set_Is_Constructor
(Def_Id
);
15459 Set_Convention
(Def_Id
, Convention_CPP
);
15461 -- Imported C++ constructors are not dispatching primitives
15462 -- because in C++ they don't have a dispatch table slot.
15463 -- However, in Ada the constructor has the profile of a
15464 -- function that returns a tagged type and therefore it has
15465 -- been treated as a primitive operation during semantic
15466 -- analysis. We now remove it from the list of primitive
15467 -- operations of the type.
15469 if Is_Tagged_Type
(Etype
(Def_Id
))
15470 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
15471 and then Is_Dispatching_Operation
(Def_Id
)
15473 Tag_Typ
:= Etype
(Def_Id
);
15475 Remove
(Primitive_Operations
(Tag_Typ
), Def_Id
);
15476 Set_Is_Dispatching_Operation
(Def_Id
, False);
15479 -- For backward compatibility, if the constructor returns a
15480 -- class wide type, and we internally change the return type to
15481 -- the corresponding root type.
15483 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
15484 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
15488 ("pragma% requires function returning a 'C'P'P_Class type",
15491 end CPP_Constructor
;
15497 when Pragma_CPP_Virtual
=>
15500 if Warn_On_Obsolescent_Feature
then
15502 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15510 when Pragma_CUDA_Device
=> CUDA_Device
: declare
15511 Arg_Node
: Node_Id
;
15512 Device_Entity
: Entity_Id
;
15515 Check_Arg_Count
(1);
15516 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
15518 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15519 Device_Entity
:= Entity
(Arg_Node
);
15521 if Ekind
(Device_Entity
) in E_Variable
15526 Add_CUDA_Device_Entity
15527 (Package_Specification_Of_Scope
(Scope
(Device_Entity
)),
15531 Error_Msg_NE
("& must be constant, variable or subprogram",
15542 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
15546 -- [, EXPRESSION]]);
15548 when Pragma_CUDA_Execute
=> CUDA_Execute
: declare
15550 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean;
15551 -- Returns True if N is an acceptable argument for CUDA_Execute,
15552 -- False otherwise.
15554 ------------------------
15555 -- Is_Acceptable_Dim3 --
15556 ------------------------
15558 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean is
15561 if Is_RTE
(Etype
(N
), RE_Dim3
)
15562 or else Is_Integer_Type
(Etype
(N
))
15567 if Nkind
(N
) = N_Aggregate
15568 and then not Null_Record_Present
(N
)
15569 and then No
(Component_Associations
(N
))
15570 and then List_Length
(Expressions
(N
)) = 3
15572 Expr
:= First
(Expressions
(N
));
15573 while Present
(Expr
) loop
15574 Analyze_And_Resolve
(Expr
, Any_Integer
);
15581 end Is_Acceptable_Dim3
;
15585 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg3
);
15586 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
15587 Kernel_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15588 Shared_Memory
: Node_Id
;
15591 -- Start of processing for CUDA_Execute
15595 Check_At_Least_N_Arguments
(3);
15596 Check_At_Most_N_Arguments
(5);
15598 Analyze_And_Resolve
(Kernel_Call
);
15599 if Nkind
(Kernel_Call
) /= N_Function_Call
15600 or else Etype
(Kernel_Call
) /= Standard_Void_Type
15602 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
15603 -- GNAT sees Kernel_Call as an N_Function_Call since
15604 -- Kernel_Call "looks" like an expression. However, only
15605 -- procedures can be kernels, so to make things easier for the
15606 -- user the error message complains about Kernel_Call not being
15607 -- a procedure call.
15609 Error_Msg_N
("first argument of & must be a procedure call", N
);
15612 Analyze
(Grid_Dimensions
);
15613 if not Is_Acceptable_Dim3
(Grid_Dimensions
) then
15615 ("second argument of & must be an Integer, Dim3 or aggregate "
15616 & "containing 3 Integers", N
);
15619 Analyze
(Block_Dimensions
);
15620 if not Is_Acceptable_Dim3
(Block_Dimensions
) then
15622 ("third argument of & must be an Integer, Dim3 or aggregate "
15623 & "containing 3 Integers", N
);
15626 if Present
(Arg4
) then
15627 Shared_Memory
:= Get_Pragma_Arg
(Arg4
);
15628 Analyze_And_Resolve
(Shared_Memory
, Any_Integer
);
15630 if Present
(Arg5
) then
15631 Stream
:= Get_Pragma_Arg
(Arg5
);
15632 Analyze_And_Resolve
(Stream
, RTE
(RE_Stream_T
));
15641 -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
15643 when Pragma_CUDA_Global
=> CUDA_Global
: declare
15644 Arg_Node
: Node_Id
;
15645 Kernel_Proc
: Entity_Id
;
15646 Pack_Id
: Entity_Id
;
15649 Check_Arg_Count
(1);
15650 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15651 Check_Arg_Is_Local_Name
(Arg1
);
15653 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15654 Analyze
(Arg_Node
);
15656 Kernel_Proc
:= Entity
(Arg_Node
);
15657 Pack_Id
:= Scope
(Kernel_Proc
);
15659 if Ekind
(Kernel_Proc
) /= E_Procedure
then
15660 Error_Msg_NE
("& must be a procedure", N
, Kernel_Proc
);
15662 elsif Ekind
(Pack_Id
) /= E_Package
15663 or else not Is_Library_Level_Entity
(Pack_Id
)
15666 ("& must reside in a library-level package", N
, Kernel_Proc
);
15669 Set_Is_CUDA_Kernel
(Kernel_Proc
);
15670 Add_CUDA_Kernel
(Pack_Id
, Kernel_Proc
);
15678 when Pragma_CPP_Vtable
=>
15681 if Warn_On_Obsolescent_Feature
then
15683 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15691 -- pragma CPU (EXPRESSION);
15693 when Pragma_CPU
=> CPU
: declare
15694 P
: constant Node_Id
:= Parent
(N
);
15700 Check_No_Identifiers
;
15701 Check_Arg_Count
(1);
15702 Arg
:= Get_Pragma_Arg
(Arg1
);
15706 if Nkind
(P
) = N_Subprogram_Body
then
15707 Check_In_Main_Program
;
15709 Analyze_And_Resolve
(Arg
, Any_Integer
);
15711 Ent
:= Defining_Unit_Name
(Specification
(P
));
15713 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15714 Ent
:= Defining_Identifier
(Ent
);
15719 if not Is_OK_Static_Expression
(Arg
) then
15720 Flag_Non_Static_Expr
15721 ("main subprogram affinity is not static!", Arg
);
15724 -- If constraint error, then we already signalled an error
15726 elsif Raises_Constraint_Error
(Arg
) then
15729 -- Otherwise check in range
15733 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15734 -- This is the entity System.Multiprocessors.CPU_Range;
15736 Val
: constant Uint
:= Expr_Value
(Arg
);
15739 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15741 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15744 ("main subprogram CPU is out of range", Arg1
);
15750 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15754 elsif Nkind
(P
) = N_Task_Definition
then
15755 Ent
:= Defining_Identifier
(Parent
(P
));
15757 -- The expression must be analyzed in the special manner
15758 -- described in "Handling of Default and Per-Object
15759 -- Expressions" in sem.ads.
15761 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15763 -- See comment in Sem_Ch13 about the following restrictions
15765 if Is_OK_Static_Expression
(Arg
) then
15766 if Expr_Value
(Arg
) = Uint_0
then
15767 Check_Restriction
(No_Tasks_Unassigned_To_CPU
, N
);
15770 Check_Restriction
(No_Dynamic_CPU_Assignment
, N
);
15773 -- Anything else is incorrect
15779 -- Check duplicate pragma before we chain the pragma in the Rep
15780 -- Item chain of Ent.
15782 Check_Duplicate_Pragma
(Ent
);
15783 Record_Rep_Item
(Ent
, N
);
15786 --------------------
15787 -- Deadline_Floor --
15788 --------------------
15790 -- pragma Deadline_Floor (time_span_EXPRESSION);
15792 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15793 P
: constant Node_Id
:= Parent
(N
);
15799 Check_No_Identifiers
;
15800 Check_Arg_Count
(1);
15802 Arg
:= Get_Pragma_Arg
(Arg1
);
15804 -- The expression must be analyzed in the special manner described
15805 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15807 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15809 -- Only protected types allowed
15811 if Nkind
(P
) /= N_Protected_Definition
then
15815 Ent
:= Defining_Identifier
(Parent
(P
));
15817 -- Check duplicate pragma before we chain the pragma in the Rep
15818 -- Item chain of Ent.
15820 Check_Duplicate_Pragma
(Ent
);
15821 Record_Rep_Item
(Ent
, N
);
15823 end Deadline_Floor
;
15829 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15831 when Pragma_Debug
=> Debug
: declare
15838 -- The condition for executing the call is that the expander
15839 -- is active and that we are not ignoring this debug pragma.
15844 (Expander_Active
and then not Is_Ignored
(N
)),
15847 if not Is_Ignored
(N
) then
15848 Set_SCO_Pragma_Enabled
(Loc
);
15851 if Arg_Count
= 2 then
15853 Make_And_Then
(Loc
,
15854 Left_Opnd
=> Relocate_Node
(Cond
),
15855 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15856 Call
:= Get_Pragma_Arg
(Arg2
);
15858 Call
:= Get_Pragma_Arg
(Arg1
);
15861 if Nkind
(Call
) in N_Expanded_Name
15864 | N_Indexed_Component
15865 | N_Selected_Component
15867 -- If this pragma Debug comes from source, its argument was
15868 -- parsed as a name form (which is syntactically identical).
15869 -- In a generic context a parameterless call will be left as
15870 -- an expanded name (if global) or selected_component if local.
15871 -- Change it to a procedure call statement now.
15873 Change_Name_To_Procedure_Call_Statement
(Call
);
15875 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15877 -- Already in the form of a procedure call statement: nothing
15878 -- to do (could happen in case of an internally generated
15884 -- All other cases: diagnose error
15887 ("argument of pragma ""Debug"" is not procedure call", Call
);
15891 -- Rewrite into a conditional with an appropriate condition. We
15892 -- wrap the procedure call in a block so that overhead from e.g.
15893 -- use of the secondary stack does not generate execution overhead
15894 -- for suppressed conditions.
15896 -- Normally the analysis that follows will freeze the subprogram
15897 -- being called. However, if the call is to a null procedure,
15898 -- we want to freeze it before creating the block, because the
15899 -- analysis that follows may be done with expansion disabled, in
15900 -- which case the body will not be generated, leading to spurious
15903 if Nkind
(Call
) = N_Procedure_Call_Statement
15904 and then Is_Entity_Name
(Name
(Call
))
15906 Analyze
(Name
(Call
));
15907 Freeze_Before
(N
, Entity
(Name
(Call
)));
15911 Make_Implicit_If_Statement
(N
,
15913 Then_Statements
=> New_List
(
15914 Make_Block_Statement
(Loc
,
15915 Handled_Statement_Sequence
=>
15916 Make_Handled_Sequence_Of_Statements
(Loc
,
15917 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15920 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15921 -- after analysis of the normally rewritten node, to capture all
15922 -- references to entities, which avoids issuing wrong warnings
15923 -- about unused entities.
15925 if GNATprove_Mode
then
15926 Rewrite
(N
, Make_Null_Statement
(Loc
));
15934 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15936 when Pragma_Debug_Policy
=>
15938 Check_Arg_Count
(1);
15939 Check_No_Identifiers
;
15940 Check_Arg_Is_Identifier
(Arg1
);
15942 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15943 -- rewrite it that way, and let the rest of the checking come
15944 -- from analyzing the rewritten pragma.
15948 Chars
=> Name_Check_Policy
,
15949 Pragma_Argument_Associations
=> New_List
(
15950 Make_Pragma_Argument_Association
(Loc
,
15951 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15953 Make_Pragma_Argument_Association
(Loc
,
15954 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15957 -------------------------------
15958 -- Default_Initial_Condition --
15959 -------------------------------
15961 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15963 when Pragma_Default_Initial_Condition
=> DIC
: declare
15970 Check_No_Identifiers
;
15971 Check_At_Most_N_Arguments
(2); -- Accounts for implicit type arg
15975 while Present
(Stmt
) loop
15977 -- Skip prior pragmas, but check for duplicates
15979 if Nkind
(Stmt
) = N_Pragma
then
15980 if Pragma_Name
(Stmt
) = Pname
then
15987 -- Skip internally generated code. Note that derived type
15988 -- declarations of untagged types with discriminants are
15989 -- rewritten as private type declarations.
15991 elsif not Comes_From_Source
(Stmt
)
15992 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15996 -- The associated private type [extension] has been found, stop
15999 elsif Nkind
(Stmt
) in N_Private_Extension_Declaration
16000 | N_Private_Type_Declaration
16002 Typ
:= Defining_Entity
(Stmt
);
16005 -- The pragma does not apply to a legal construct, issue an
16006 -- error and stop the analysis.
16012 Stmt
:= Prev
(Stmt
);
16015 -- The pragma does not apply to a legal construct, issue an error
16016 -- and stop the analysis.
16022 -- A pragma that applies to a Ghost entity becomes Ghost for the
16023 -- purposes of legality checks and removal of ignored Ghost code.
16025 Mark_Ghost_Pragma
(N
, Typ
);
16027 -- The pragma signals that the type defines its own DIC assertion
16030 Set_Has_Own_DIC
(Typ
);
16032 -- A type entity argument is appended to facilitate inheriting the
16033 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
16034 -- though that extra argument isn't documented for the pragma.
16037 -- When the pragma has no arguments, create an argument with
16038 -- the value Empty, so the type name argument can be appended
16039 -- following it (since it's expected as the second argument).
16042 Set_Pragma_Argument_Associations
(N
, New_List
(
16043 Make_Pragma_Argument_Association
(Sloc
(Typ
),
16044 Expression
=> Empty
)));
16048 (Pragma_Argument_Associations
(N
),
16049 Make_Pragma_Argument_Association
(Sloc
(Typ
),
16050 Expression
=> New_Occurrence_Of
(Typ
, Sloc
(Typ
))));
16053 -- Chain the pragma on the rep item chain for further processing
16055 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16057 -- Create the declaration of the procedure which verifies the
16058 -- assertion expression of pragma DIC at runtime.
16060 Build_DIC_Procedure_Declaration
(Typ
);
16063 ----------------------------------
16064 -- Default_Scalar_Storage_Order --
16065 ----------------------------------
16067 -- pragma Default_Scalar_Storage_Order
16068 -- (High_Order_First | Low_Order_First);
16070 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
16071 Default
: Character;
16075 Check_Arg_Count
(1);
16077 -- Default_Scalar_Storage_Order can appear as a configuration
16078 -- pragma, or in a declarative part of a package spec.
16080 if not Is_Configuration_Pragma
then
16081 Check_Is_In_Decl_Part_Or_Package_Spec
;
16084 Check_No_Identifiers
;
16085 Check_Arg_Is_One_Of
16086 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
16087 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16088 Default
:= Fold_Upper
(Name_Buffer
(1));
16090 if not Support_Nondefault_SSO_On_Target
16091 and then Ttypes
.Bytes_Big_Endian
/= (Default
= 'H')
16093 if Warn_On_Unrecognized_Pragma
then
16095 ("non-default Scalar_Storage_Order not supported "
16096 & "on target?g?", N
);
16098 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
16101 -- Here set the specified default
16104 Opt
.Default_SSO
:= Default
;
16108 --------------------------
16109 -- Default_Storage_Pool --
16110 --------------------------
16112 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
16114 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
16119 Check_Arg_Count
(1);
16121 -- Default_Storage_Pool can appear as a configuration pragma, or
16122 -- in a declarative part of a package spec.
16124 if not Is_Configuration_Pragma
then
16125 Check_Is_In_Decl_Part_Or_Package_Spec
;
16128 if From_Aspect_Specification
(N
) then
16130 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
16132 if not In_Open_Scopes
(E
) then
16134 ("aspect must apply to package or subprogram", N
);
16139 if Present
(Arg1
) then
16140 Pool
:= Get_Pragma_Arg
(Arg1
);
16142 -- Case of Default_Storage_Pool (null);
16144 if Nkind
(Pool
) = N_Null
then
16147 -- This is an odd case, this is not really an expression,
16148 -- so we don't have a type for it. So just set the type to
16151 Set_Etype
(Pool
, Empty
);
16153 -- Case of Default_Storage_Pool (Standard);
16155 elsif Nkind
(Pool
) = N_Identifier
16156 and then Chars
(Pool
) = Name_Standard
16160 if Entity
(Pool
) /= Standard_Standard
then
16162 ("package Standard is not directly visible", Arg1
);
16165 -- Case of Default_Storage_Pool (storage_pool_NAME);
16168 -- If it's a configuration pragma, then the only allowed
16169 -- argument is "null".
16171 if Is_Configuration_Pragma
then
16172 Error_Pragma_Arg
("NULL or Standard expected", Arg1
);
16175 -- The expected type for a non-"null" argument is
16176 -- Root_Storage_Pool'Class, and the pool must be a variable.
16178 Analyze_And_Resolve
16179 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
16181 if Is_Variable
(Pool
) then
16183 -- A pragma that applies to a Ghost entity becomes Ghost
16184 -- for the purposes of legality checks and removal of
16185 -- ignored Ghost code.
16187 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
16191 ("default storage pool must be a variable", Arg1
);
16195 -- Record the pool name (or null). Freeze.Freeze_Entity for an
16196 -- access type will use this information to set the appropriate
16197 -- attributes of the access type. If the pragma appears in a
16198 -- generic unit it is ignored, given that it may refer to a
16201 if not Inside_A_Generic
then
16202 Default_Pool
:= Pool
;
16205 end Default_Storage_Pool
;
16211 -- pragma Depends (DEPENDENCY_RELATION);
16213 -- DEPENDENCY_RELATION ::=
16215 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
16217 -- DEPENDENCY_CLAUSE ::=
16218 -- OUTPUT_LIST =>[+] INPUT_LIST
16219 -- | NULL_DEPENDENCY_CLAUSE
16221 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
16223 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
16225 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
16227 -- OUTPUT ::= NAME | FUNCTION_RESULT
16230 -- where FUNCTION_RESULT is a function Result attribute_reference
16232 -- Characteristics:
16234 -- * Analysis - The annotation undergoes initial checks to verify
16235 -- the legal placement and context. Secondary checks fully analyze
16236 -- the dependency clauses in:
16238 -- Analyze_Depends_In_Decl_Part
16240 -- * Expansion - None.
16242 -- * Template - The annotation utilizes the generic template of the
16243 -- related subprogram [body] when it is:
16245 -- aspect on subprogram declaration
16246 -- aspect on stand-alone subprogram body
16247 -- pragma on stand-alone subprogram body
16249 -- The annotation must prepare its own template when it is:
16251 -- pragma on subprogram declaration
16253 -- * Globals - Capture of global references must occur after full
16256 -- * Instance - The annotation is instantiated automatically when
16257 -- the related generic subprogram [body] is instantiated except for
16258 -- the "pragma on subprogram declaration" case. In that scenario
16259 -- the annotation must instantiate itself.
16261 when Pragma_Depends
=> Depends
: declare
16263 Spec_Id
: Entity_Id
;
16264 Subp_Decl
: Node_Id
;
16267 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16271 -- Chain the pragma on the contract for further processing by
16272 -- Analyze_Depends_In_Decl_Part.
16274 Add_Contract_Item
(N
, Spec_Id
);
16276 -- Fully analyze the pragma when it appears inside an entry
16277 -- or subprogram body because it cannot benefit from forward
16280 if Nkind
(Subp_Decl
) in N_Entry_Body
16281 | N_Subprogram_Body
16282 | N_Subprogram_Body_Stub
16284 -- The legality checks of pragmas Depends and Global are
16285 -- affected by the SPARK mode in effect and the volatility
16286 -- of the context. In addition these two pragmas are subject
16287 -- to an inherent order:
16292 -- Analyze all these pragmas in the order outlined above
16294 Analyze_If_Present
(Pragma_SPARK_Mode
);
16295 Analyze_If_Present
(Pragma_Volatile_Function
);
16296 Analyze_If_Present
(Pragma_Side_Effects
);
16297 Analyze_If_Present
(Pragma_Global
);
16298 Analyze_Depends_In_Decl_Part
(N
);
16303 ---------------------
16304 -- Detect_Blocking --
16305 ---------------------
16307 -- pragma Detect_Blocking;
16309 when Pragma_Detect_Blocking
=>
16311 Check_Arg_Count
(0);
16312 Check_Valid_Configuration_Pragma
;
16313 Detect_Blocking
:= True;
16315 ------------------------------------
16316 -- Disable_Atomic_Synchronization --
16317 ------------------------------------
16319 -- pragma Disable_Atomic_Synchronization [(Entity)];
16321 when Pragma_Disable_Atomic_Synchronization
=>
16323 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
16325 -------------------
16326 -- Discard_Names --
16327 -------------------
16329 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
16331 when Pragma_Discard_Names
=> Discard_Names
: declare
16336 Check_Ada_83_Warning
;
16338 -- Deal with configuration pragma case
16340 if Is_Configuration_Pragma
then
16341 if Arg_Count
/= 0 then
16343 ("nonzero number of arguments for configuration pragma%");
16345 Global_Discard_Names
:= True;
16349 -- Otherwise, check correct appropriate context
16352 Check_Is_In_Decl_Part_Or_Package_Spec
;
16354 if Arg_Count
= 0 then
16356 -- If there is no parameter, then from now on this pragma
16357 -- applies to any enumeration, exception or tagged type
16358 -- defined in the current declarative part, and recursively
16359 -- to any nested scope.
16361 Set_Discard_Names
(Current_Scope
);
16365 Check_Arg_Count
(1);
16366 Check_Optional_Identifier
(Arg1
, Name_On
);
16367 Check_Arg_Is_Local_Name
(Arg1
);
16369 E_Id
:= Get_Pragma_Arg
(Arg1
);
16371 if Etype
(E_Id
) = Any_Type
then
16375 E
:= Entity
(E_Id
);
16377 -- A pragma that applies to a Ghost entity becomes Ghost for
16378 -- the purposes of legality checks and removal of ignored
16381 Mark_Ghost_Pragma
(N
, E
);
16383 if (Is_First_Subtype
(E
)
16385 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
16386 or else Ekind
(E
) = E_Exception
16388 Set_Discard_Names
(E
);
16389 Record_Rep_Item
(E
, N
);
16393 ("inappropriate entity for pragma%", Arg1
);
16399 ------------------------
16400 -- Dispatching_Domain --
16401 ------------------------
16403 -- pragma Dispatching_Domain (EXPRESSION);
16405 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
16406 P
: constant Node_Id
:= Parent
(N
);
16412 Check_No_Identifiers
;
16413 Check_Arg_Count
(1);
16415 -- This pragma is born obsolete, but not the aspect
16417 if not From_Aspect_Specification
(N
) then
16419 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16422 if Nkind
(P
) = N_Task_Definition
then
16423 Arg
:= Get_Pragma_Arg
(Arg1
);
16424 Ent
:= Defining_Identifier
(Parent
(P
));
16426 -- A pragma that applies to a Ghost entity becomes Ghost for
16427 -- the purposes of legality checks and removal of ignored Ghost
16430 Mark_Ghost_Pragma
(N
, Ent
);
16432 -- The expression must be analyzed in the special manner
16433 -- described in "Handling of Default and Per-Object
16434 -- Expressions" in sem.ads.
16436 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
16438 -- Check duplicate pragma before we chain the pragma in the Rep
16439 -- Item chain of Ent.
16441 Check_Duplicate_Pragma
(Ent
);
16442 Record_Rep_Item
(Ent
, N
);
16444 -- Anything else is incorrect
16449 end Dispatching_Domain
;
16455 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
16457 when Pragma_Elaborate
=> Elaborate
: declare
16462 -- Pragma must be in context items list of a compilation unit
16464 if not Is_In_Context_Clause
then
16468 -- Must be at least one argument
16470 if Arg_Count
= 0 then
16471 Error_Pragma
("pragma% requires at least one argument");
16474 -- In Ada 83 mode, there can be no items following it in the
16475 -- context list except other pragmas and implicit with clauses
16476 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
16477 -- placement rule does not apply.
16479 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
16481 while Present
(Citem
) loop
16482 if Nkind
(Citem
) = N_Pragma
16483 or else (Nkind
(Citem
) = N_With_Clause
16484 and then Implicit_With
(Citem
))
16489 ("(Ada 83) pragma% must be at end of context clause");
16496 -- Finally, the arguments must all be units mentioned in a with
16497 -- clause in the same context clause. Note we already checked (in
16498 -- Par.Prag) that the arguments are all identifiers or selected
16502 Outer
: while Present
(Arg
) loop
16503 Citem
:= First
(List_Containing
(N
));
16504 Inner
: while Citem
/= N
loop
16505 if Nkind
(Citem
) = N_With_Clause
16506 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
16508 Set_Elaborate_Present
(Citem
, True);
16509 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
16511 -- With the pragma present, elaboration calls on
16512 -- subprograms from the named unit need no further
16513 -- checks, as long as the pragma appears in the current
16514 -- compilation unit. If the pragma appears in some unit
16515 -- in the context, there might still be a need for an
16516 -- Elaborate_All_Desirable from the current compilation
16517 -- to the named unit, so we keep the check enabled. This
16518 -- does not apply in SPARK mode, where we allow pragma
16519 -- Elaborate, but we don't trust it to be right so we
16520 -- will still insist on the Elaborate_All.
16522 if Legacy_Elaboration_Checks
16523 and then In_Extended_Main_Source_Unit
(N
)
16524 and then SPARK_Mode
/= On
16526 Set_Suppress_Elaboration_Warnings
16527 (Entity
(Name
(Citem
)));
16538 ("argument of pragma% is not withed unit", Arg
);
16545 -------------------
16546 -- Elaborate_All --
16547 -------------------
16549 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
16551 when Pragma_Elaborate_All
=> Elaborate_All
: declare
16556 Check_Ada_83_Warning
;
16558 -- Pragma must be in context items list of a compilation unit
16560 if not Is_In_Context_Clause
then
16564 -- Must be at least one argument
16566 if Arg_Count
= 0 then
16567 Error_Pragma
("pragma% requires at least one argument");
16570 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
16571 -- have to appear at the end of the context clause, but may
16572 -- appear mixed in with other items, even in Ada 83 mode.
16574 -- Final check: the arguments must all be units mentioned in
16575 -- a with clause in the same context clause. Note that we
16576 -- already checked (in Par.Prag) that all the arguments are
16577 -- either identifiers or selected components.
16580 Outr
: while Present
(Arg
) loop
16581 Citem
:= First
(List_Containing
(N
));
16582 Innr
: while Citem
/= N
loop
16583 if Nkind
(Citem
) = N_With_Clause
16584 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
16586 Set_Elaborate_All_Present
(Citem
, True);
16587 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
16589 -- Suppress warnings and elaboration checks on the named
16590 -- unit if the pragma is in the current compilation, as
16591 -- for pragma Elaborate.
16593 if Legacy_Elaboration_Checks
16594 and then In_Extended_Main_Source_Unit
(N
)
16596 Set_Suppress_Elaboration_Warnings
16597 (Entity
(Name
(Citem
)));
16608 ("argument of pragma% is not withed unit", Arg
);
16615 --------------------
16616 -- Elaborate_Body --
16617 --------------------
16619 -- pragma Elaborate_Body [( library_unit_NAME )];
16621 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
16622 Cunit_Node
: Node_Id
;
16623 Cunit_Ent
: Entity_Id
;
16626 Check_Ada_83_Warning
;
16627 Check_Valid_Library_Unit_Pragma
;
16629 -- If N was rewritten as a null statement there is nothing more
16632 if Nkind
(N
) = N_Null_Statement
then
16636 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16637 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16639 -- A pragma that applies to a Ghost entity becomes Ghost for the
16640 -- purposes of legality checks and removal of ignored Ghost code.
16642 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
16644 if Nkind
(Unit
(Cunit_Node
)) in
16645 N_Package_Body | N_Subprogram_Body
16647 Error_Pragma
("pragma% must refer to a spec, not a body");
16649 Set_Body_Required
(Cunit_Node
);
16650 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
16652 -- If we are in dynamic elaboration mode, then we suppress
16653 -- elaboration warnings for the unit, since it is definitely
16654 -- fine NOT to do dynamic checks at the first level (and such
16655 -- checks will be suppressed because no elaboration boolean
16656 -- is created for Elaborate_Body packages).
16658 -- But in the static model of elaboration, Elaborate_Body is
16659 -- definitely NOT good enough to ensure elaboration safety on
16660 -- its own, since the body may WITH other units that are not
16661 -- safe from an elaboration point of view, so a client must
16662 -- still do an Elaborate_All on such units.
16664 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16665 -- Elaborate_Body always suppressed elab warnings.
16667 if Legacy_Elaboration_Checks
16668 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
16670 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
16673 end Elaborate_Body
;
16675 ------------------------
16676 -- Elaboration_Checks --
16677 ------------------------
16679 -- pragma Elaboration_Checks (Static | Dynamic);
16681 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
16682 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
16683 -- Emit an error if the current context list already contains
16684 -- a previous Elaboration_Checks pragma. This routine raises
16685 -- Pragma_Exit if a duplicate is found.
16687 procedure Ignore_Elaboration_Checks_Pragma
;
16688 -- Warn that the effects of the pragma are ignored. This routine
16689 -- raises Pragma_Exit.
16691 -----------------------------------------------
16692 -- Check_Duplicate_Elaboration_Checks_Pragma --
16693 -----------------------------------------------
16695 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16700 while Present
(Item
) loop
16701 if Nkind
(Item
) = N_Pragma
16702 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16712 end Check_Duplicate_Elaboration_Checks_Pragma
;
16714 --------------------------------------
16715 -- Ignore_Elaboration_Checks_Pragma --
16716 --------------------------------------
16718 procedure Ignore_Elaboration_Checks_Pragma
is
16720 Error_Msg_Name_1
:= Pname
;
16721 Error_Msg_N
("??effects of pragma % are ignored", N
);
16723 ("\place pragma on initial declaration of library unit", N
);
16726 end Ignore_Elaboration_Checks_Pragma
;
16730 Context
: constant Node_Id
:= Parent
(N
);
16733 -- Start of processing for Elaboration_Checks
16737 Check_Arg_Count
(1);
16738 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16740 -- The pragma appears in a configuration file
16742 if No
(Context
) then
16743 Check_Valid_Configuration_Pragma
;
16744 Check_Duplicate_Elaboration_Checks_Pragma
;
16746 -- The pragma acts as a configuration pragma in a compilation unit
16748 -- pragma Elaboration_Checks (...);
16749 -- package Pack is ...;
16751 elsif Nkind
(Context
) = N_Compilation_Unit
16752 and then List_Containing
(N
) = Context_Items
(Context
)
16754 Check_Valid_Configuration_Pragma
;
16755 Check_Duplicate_Elaboration_Checks_Pragma
;
16757 Unt
:= Unit
(Context
);
16759 -- The pragma must appear on the initial declaration of a unit.
16760 -- If this is not the case, warn that the effects of the pragma
16763 if Nkind
(Unt
) = N_Package_Body
then
16764 Ignore_Elaboration_Checks_Pragma
;
16766 -- Check the Acts_As_Spec flag of the compilation units itself
16767 -- to determine whether the subprogram body completes since it
16768 -- has not been analyzed yet. This is safe because compilation
16769 -- units are not overloadable.
16771 elsif Nkind
(Unt
) = N_Subprogram_Body
16772 and then not Acts_As_Spec
(Context
)
16774 Ignore_Elaboration_Checks_Pragma
;
16776 elsif Nkind
(Unt
) = N_Subunit
then
16777 Ignore_Elaboration_Checks_Pragma
;
16780 -- Otherwise the pragma does not appear at the configuration level
16787 -- At this point the pragma is not a duplicate, and appears in the
16788 -- proper context. Set the elaboration model in effect.
16790 Dynamic_Elaboration_Checks
:=
16791 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16792 end Elaboration_Checks
;
16798 -- pragma Eliminate (
16799 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16800 -- [Entity =>] IDENTIFIER |
16801 -- SELECTED_COMPONENT |
16803 -- [, Source_Location => SOURCE_TRACE]);
16805 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16806 -- SOURCE_TRACE ::= STRING_LITERAL
16808 when Pragma_Eliminate
=> Eliminate
: declare
16809 Args
: Args_List
(1 .. 5);
16810 Names
: constant Name_List
(1 .. 5) := (
16813 Name_Parameter_Types
,
16815 Name_Source_Location
);
16817 -- Note : Parameter_Types and Result_Type are leftovers from
16818 -- prior implementations of the pragma. They are not generated
16819 -- by the gnatelim tool, and play no role in selecting which
16820 -- of a set of overloaded names is chosen for elimination.
16822 Unit_Name
: Node_Id
renames Args
(1);
16823 Entity
: Node_Id
renames Args
(2);
16824 Parameter_Types
: Node_Id
renames Args
(3);
16825 Result_Type
: Node_Id
renames Args
(4);
16826 Source_Location
: Node_Id
renames Args
(5);
16830 Check_Valid_Configuration_Pragma
;
16831 Gather_Associations
(Names
, Args
);
16833 if No
(Unit_Name
) then
16834 Error_Pragma
("missing Unit_Name argument for pragma%");
16838 and then (Present
(Parameter_Types
)
16840 Present
(Result_Type
)
16842 Present
(Source_Location
))
16844 Error_Pragma
("missing Entity argument for pragma%");
16847 if (Present
(Parameter_Types
)
16849 Present
(Result_Type
))
16851 Present
(Source_Location
)
16854 ("parameter profile and source location cannot be used "
16855 & "together in pragma%");
16858 Process_Eliminate_Pragma
16867 -----------------------------------
16868 -- Enable_Atomic_Synchronization --
16869 -----------------------------------
16871 -- pragma Enable_Atomic_Synchronization [(Entity)];
16873 when Pragma_Enable_Atomic_Synchronization
=>
16875 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16877 -----------------------
16878 -- Exceptional_Cases --
16879 -----------------------
16881 -- pragma Exceptional_Cases ( EXCEPTIONAL_CONTRACT_LIST );
16883 -- EXCEPTIONAL_CONTRACT_LIST ::=
16884 -- ( EXCEPTIONAL_CONTRACT {, EXCEPTIONAL_CONTRACT })
16886 -- EXCEPTIONAL_CONTRACT ::=
16887 -- EXCEPTION_CHOICE {'|' EXCEPTION_CHOICE} => CONSEQUENCE
16891 -- CONSEQUENCE ::= boolean_EXPRESSION
16893 -- Characteristics:
16895 -- * Analysis - The annotation undergoes initial checks to verify
16896 -- the legal placement and context. Secondary checks preanalyze the
16899 -- Analyze_Exceptional_Cases_In_Decl_Part
16901 -- * Expansion - The annotation is expanded during the expansion of
16902 -- the related subprogram [body] contract as performed in:
16904 -- Expand_Subprogram_Contract
16906 -- * Template - The annotation utilizes the generic template of the
16907 -- related subprogram [body] when it is:
16909 -- aspect on subprogram declaration
16910 -- aspect on stand-alone subprogram body
16911 -- pragma on stand-alone subprogram body
16913 -- The annotation must prepare its own template when it is:
16915 -- pragma on subprogram declaration
16917 -- * Globals - Capture of global references must occur after full
16920 -- * Instance - The annotation is instantiated automatically when
16921 -- the related generic subprogram [body] is instantiated except for
16922 -- the "pragma on subprogram declaration" case. In that scenario
16923 -- the annotation must instantiate itself.
16925 when Pragma_Exceptional_Cases
=> Exceptional_Cases
: declare
16926 Spec_Id
: Entity_Id
;
16927 Subp_Decl
: Node_Id
;
16928 Subp_Spec
: Node_Id
;
16932 Check_No_Identifiers
;
16933 Check_Arg_Count
(1);
16935 -- Ensure the proper placement of the pragma. Exceptional_Cases
16936 -- must be associated with a subprogram declaration or a body that
16940 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16942 -- Generic subprogram
16944 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16947 -- Body acts as spec
16949 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16950 and then No
(Corresponding_Spec
(Subp_Decl
))
16954 -- Body stub acts as spec
16956 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16957 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16963 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16964 Subp_Spec
:= Specification
(Subp_Decl
);
16966 -- Pragma Exceptional_Cases is forbidden on null procedures,
16967 -- as this may lead to potential ambiguities in behavior when
16968 -- interface null procedures are involved. Also, it just
16969 -- wouldn't make sense, because null procedures do not raise
16972 if Nkind
(Subp_Spec
) = N_Procedure_Specification
16973 and then Null_Present
(Subp_Spec
)
16975 Error_Msg_N
(Fix_Error
16976 ("pragma % cannot apply to null procedure"), N
);
16984 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16986 -- In order to call Is_Function_With_Side_Effects, analyze pragma
16987 -- Side_Effects if present.
16989 Analyze_If_Present
(Pragma_Side_Effects
);
16991 -- Pragma Exceptional_Cases is not allowed on functions without
16994 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
16995 and then not Is_Function_With_Side_Effects
(Spec_Id
)
16997 Error_Msg_Sloc
:= GEC_Exceptional_Cases_On_Function
;
16999 if Ekind
(Spec_Id
) = E_Function
then
17000 Error_Msg_N
(Fix_Error
17001 ("pragma % cannot apply to function '[[]']"), N
);
17004 elsif Ekind
(Spec_Id
) = E_Generic_Function
then
17005 Error_Msg_N
(Fix_Error
17006 ("pragma % cannot apply to generic function '[[]']"), N
);
17011 -- A pragma that applies to a Ghost entity becomes Ghost for the
17012 -- purposes of legality checks and removal of ignored Ghost code.
17014 Mark_Ghost_Pragma
(N
, Spec_Id
);
17015 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
17017 -- Chain the pragma on the contract for further processing by
17018 -- Analyze_Exceptional_Cases_In_Decl_Part.
17020 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
17022 -- Fully analyze the pragma when it appears inside a subprogram
17023 -- body because it cannot benefit from forward references.
17025 if Nkind
(Subp_Decl
) in N_Subprogram_Body
17026 | N_Subprogram_Body_Stub
17028 -- The legality checks of pragma Exceptional_Cases are
17029 -- affected by the SPARK mode in effect and the volatility
17030 -- of the context. Analyze all pragmas in a specific order.
17032 Analyze_If_Present
(Pragma_SPARK_Mode
);
17033 Analyze_If_Present
(Pragma_Volatile_Function
);
17034 Analyze_Exceptional_Cases_In_Decl_Part
(N
);
17036 end Exceptional_Cases
;
17043 -- [ Convention =>] convention_IDENTIFIER,
17044 -- [ Entity =>] LOCAL_NAME
17045 -- [, [External_Name =>] static_string_EXPRESSION ]
17046 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17048 when Pragma_Export
=> Export
: declare
17050 Def_Id
: Entity_Id
;
17052 pragma Warnings
(Off
, C
);
17055 Check_Ada_83_Warning
;
17059 Name_External_Name
,
17062 Check_At_Least_N_Arguments
(2);
17063 Check_At_Most_N_Arguments
(4);
17065 -- In Relaxed_RM_Semantics, support old Ada 83 style:
17066 -- pragma Export (Entity, "external name");
17068 if Relaxed_RM_Semantics
17069 and then Arg_Count
= 2
17070 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
17073 Def_Id
:= Get_Pragma_Arg
(Arg1
);
17076 if not Is_Entity_Name
(Def_Id
) then
17077 Error_Pragma_Arg
("entity name required", Arg1
);
17080 Def_Id
:= Entity
(Def_Id
);
17081 Set_Exported
(Def_Id
, Arg1
);
17084 Process_Convention
(C
, Def_Id
);
17086 -- A pragma that applies to a Ghost entity becomes Ghost for
17087 -- the purposes of legality checks and removal of ignored Ghost
17090 Mark_Ghost_Pragma
(N
, Def_Id
);
17092 if Ekind
(Def_Id
) /= E_Constant
then
17093 Note_Possible_Modification
17094 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
17097 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
17098 Set_Exported
(Def_Id
, Arg2
);
17101 -- If the entity is a deferred constant, propagate the information
17102 -- to the full view, because gigi elaborates the full view only.
17104 if Ekind
(Def_Id
) = E_Constant
17105 and then Present
(Full_View
(Def_Id
))
17108 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
17110 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
17111 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
17113 (Id2
, Einfo
.Entities
.Interface_Name
(Def_Id
));
17118 ---------------------
17119 -- Export_Function --
17120 ---------------------
17122 -- pragma Export_Function (
17123 -- [Internal =>] LOCAL_NAME
17124 -- [, [External =>] EXTERNAL_SYMBOL]
17125 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17126 -- [, [Result_Type =>] TYPE_DESIGNATOR]
17127 -- [, [Mechanism =>] MECHANISM]
17128 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17130 -- EXTERNAL_SYMBOL ::=
17132 -- | static_string_EXPRESSION
17134 -- PARAMETER_TYPES ::=
17136 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17138 -- TYPE_DESIGNATOR ::=
17140 -- | subtype_Name ' Access
17144 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17146 -- MECHANISM_ASSOCIATION ::=
17147 -- [formal_parameter_NAME =>] MECHANISM_NAME
17149 -- MECHANISM_NAME ::=
17153 when Pragma_Export_Function
=> Export_Function
: declare
17154 Args
: Args_List
(1 .. 6);
17155 Names
: constant Name_List
(1 .. 6) := (
17158 Name_Parameter_Types
,
17161 Name_Result_Mechanism
);
17163 Internal
: Node_Id
renames Args
(1);
17164 External
: Node_Id
renames Args
(2);
17165 Parameter_Types
: Node_Id
renames Args
(3);
17166 Result_Type
: Node_Id
renames Args
(4);
17167 Mechanism
: Node_Id
renames Args
(5);
17168 Result_Mechanism
: Node_Id
renames Args
(6);
17172 Gather_Associations
(Names
, Args
);
17173 Process_Extended_Import_Export_Subprogram_Pragma
(
17174 Arg_Internal
=> Internal
,
17175 Arg_External
=> External
,
17176 Arg_Parameter_Types
=> Parameter_Types
,
17177 Arg_Result_Type
=> Result_Type
,
17178 Arg_Mechanism
=> Mechanism
,
17179 Arg_Result_Mechanism
=> Result_Mechanism
);
17180 end Export_Function
;
17182 -------------------
17183 -- Export_Object --
17184 -------------------
17186 -- pragma Export_Object (
17187 -- [Internal =>] LOCAL_NAME
17188 -- [, [External =>] EXTERNAL_SYMBOL]
17189 -- [, [Size =>] EXTERNAL_SYMBOL]);
17191 -- EXTERNAL_SYMBOL ::=
17193 -- | static_string_EXPRESSION
17195 -- PARAMETER_TYPES ::=
17197 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17199 -- TYPE_DESIGNATOR ::=
17201 -- | subtype_Name ' Access
17205 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17207 -- MECHANISM_ASSOCIATION ::=
17208 -- [formal_parameter_NAME =>] MECHANISM_NAME
17210 -- MECHANISM_NAME ::=
17214 when Pragma_Export_Object
=> Export_Object
: declare
17215 Args
: Args_List
(1 .. 3);
17216 Names
: constant Name_List
(1 .. 3) := (
17221 Internal
: Node_Id
renames Args
(1);
17222 External
: Node_Id
renames Args
(2);
17223 Size
: Node_Id
renames Args
(3);
17227 Gather_Associations
(Names
, Args
);
17228 Process_Extended_Import_Export_Object_Pragma
(
17229 Arg_Internal
=> Internal
,
17230 Arg_External
=> External
,
17234 ----------------------
17235 -- Export_Procedure --
17236 ----------------------
17238 -- pragma Export_Procedure (
17239 -- [Internal =>] LOCAL_NAME
17240 -- [, [External =>] EXTERNAL_SYMBOL]
17241 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17242 -- [, [Mechanism =>] MECHANISM]);
17244 -- EXTERNAL_SYMBOL ::=
17246 -- | static_string_EXPRESSION
17248 -- PARAMETER_TYPES ::=
17250 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17252 -- TYPE_DESIGNATOR ::=
17254 -- | subtype_Name ' Access
17258 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17260 -- MECHANISM_ASSOCIATION ::=
17261 -- [formal_parameter_NAME =>] MECHANISM_NAME
17263 -- MECHANISM_NAME ::=
17267 when Pragma_Export_Procedure
=> Export_Procedure
: declare
17268 Args
: Args_List
(1 .. 4);
17269 Names
: constant Name_List
(1 .. 4) := (
17272 Name_Parameter_Types
,
17275 Internal
: Node_Id
renames Args
(1);
17276 External
: Node_Id
renames Args
(2);
17277 Parameter_Types
: Node_Id
renames Args
(3);
17278 Mechanism
: Node_Id
renames Args
(4);
17282 Gather_Associations
(Names
, Args
);
17283 Process_Extended_Import_Export_Subprogram_Pragma
(
17284 Arg_Internal
=> Internal
,
17285 Arg_External
=> External
,
17286 Arg_Parameter_Types
=> Parameter_Types
,
17287 Arg_Mechanism
=> Mechanism
);
17288 end Export_Procedure
;
17290 -----------------------------
17291 -- Export_Valued_Procedure --
17292 -----------------------------
17294 -- pragma Export_Valued_Procedure (
17295 -- [Internal =>] LOCAL_NAME
17296 -- [, [External =>] EXTERNAL_SYMBOL,]
17297 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17298 -- [, [Mechanism =>] MECHANISM]);
17300 -- EXTERNAL_SYMBOL ::=
17302 -- | static_string_EXPRESSION
17304 -- PARAMETER_TYPES ::=
17306 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17308 -- TYPE_DESIGNATOR ::=
17310 -- | subtype_Name ' Access
17314 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17316 -- MECHANISM_ASSOCIATION ::=
17317 -- [formal_parameter_NAME =>] MECHANISM_NAME
17319 -- MECHANISM_NAME ::=
17323 when Pragma_Export_Valued_Procedure
=>
17324 Export_Valued_Procedure
: declare
17325 Args
: Args_List
(1 .. 4);
17326 Names
: constant Name_List
(1 .. 4) := (
17329 Name_Parameter_Types
,
17332 Internal
: Node_Id
renames Args
(1);
17333 External
: Node_Id
renames Args
(2);
17334 Parameter_Types
: Node_Id
renames Args
(3);
17335 Mechanism
: Node_Id
renames Args
(4);
17339 Gather_Associations
(Names
, Args
);
17340 Process_Extended_Import_Export_Subprogram_Pragma
(
17341 Arg_Internal
=> Internal
,
17342 Arg_External
=> External
,
17343 Arg_Parameter_Types
=> Parameter_Types
,
17344 Arg_Mechanism
=> Mechanism
);
17345 end Export_Valued_Procedure
;
17347 -------------------
17348 -- Extend_System --
17349 -------------------
17351 -- pragma Extend_System ([Name =>] Identifier);
17353 when Pragma_Extend_System
=>
17355 Check_Valid_Configuration_Pragma
;
17356 Check_Arg_Count
(1);
17357 Check_Optional_Identifier
(Arg1
, Name_Name
);
17358 Check_Arg_Is_Identifier
(Arg1
);
17360 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
17363 and then Name_Buffer
(1 .. 4) = "aux_"
17365 if Present
(System_Extend_Pragma_Arg
) then
17366 if Chars
(Get_Pragma_Arg
(Arg1
)) =
17367 Chars
(Expression
(System_Extend_Pragma_Arg
))
17371 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
17372 Error_Pragma
("pragma% conflicts with that #");
17376 System_Extend_Pragma_Arg
:= Arg1
;
17378 if not GNAT_Mode
then
17379 System_Extend_Unit
:= Arg1
;
17383 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
17386 ------------------------
17387 -- Extensions_Allowed --
17388 ------------------------
17390 -- pragma Extensions_Allowed (ON | OFF | ALL);
17392 when Pragma_Extensions_Allowed
=>
17394 Check_Arg_Count
(1);
17395 Check_No_Identifiers
;
17396 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
, Name_All
);
17398 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
17399 Ada_Version
:= Ada_With_Core_Extensions
;
17400 elsif Chars
(Get_Pragma_Arg
(Arg1
)) = Name_All
then
17401 Ada_Version
:= Ada_With_All_Extensions
;
17403 Ada_Version
:= Ada_Version_Explicit
;
17404 Ada_Version_Pragma
:= Empty
;
17407 ------------------------
17408 -- Extensions_Visible --
17409 ------------------------
17411 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
17413 -- Characteristics:
17415 -- * Analysis - The annotation is fully analyzed immediately upon
17416 -- elaboration as its expression must be static.
17418 -- * Expansion - None.
17420 -- * Template - The annotation utilizes the generic template of the
17421 -- related subprogram [body] when it is:
17423 -- aspect on subprogram declaration
17424 -- aspect on stand-alone subprogram body
17425 -- pragma on stand-alone subprogram body
17427 -- The annotation must prepare its own template when it is:
17429 -- pragma on subprogram declaration
17431 -- * Globals - Capture of global references must occur after full
17434 -- * Instance - The annotation is instantiated automatically when
17435 -- the related generic subprogram [body] is instantiated except for
17436 -- the "pragma on subprogram declaration" case. In that scenario
17437 -- the annotation must instantiate itself.
17439 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
17440 Formal
: Entity_Id
;
17441 Has_OK_Formal
: Boolean := False;
17442 Spec_Id
: Entity_Id
;
17443 Subp_Decl
: Node_Id
;
17447 Check_No_Identifiers
;
17448 Check_At_Most_N_Arguments
(1);
17451 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
17453 -- Abstract subprogram declaration
17455 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
17458 -- Generic subprogram declaration
17460 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
17463 -- Body acts as spec
17465 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
17466 and then No
(Corresponding_Spec
(Subp_Decl
))
17470 -- Body stub acts as spec
17472 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
17473 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
17477 -- Subprogram declaration
17479 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
17482 -- Otherwise the pragma is associated with an illegal construct
17485 Error_Pragma
("pragma % must apply to a subprogram");
17488 -- Mark the pragma as Ghost if the related subprogram is also
17489 -- Ghost. This also ensures that any expansion performed further
17490 -- below will produce Ghost nodes.
17492 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
17493 Mark_Ghost_Pragma
(N
, Spec_Id
);
17495 -- Chain the pragma on the contract for completeness
17497 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
17499 -- The legality checks of pragma Extension_Visible are affected
17500 -- by the SPARK mode in effect. Analyze all pragmas in specific
17503 Analyze_If_Present
(Pragma_SPARK_Mode
);
17505 -- Examine the formals of the related subprogram
17507 Formal
:= First_Formal
(Spec_Id
);
17508 while Present
(Formal
) loop
17510 -- At least one of the formals is of a specific tagged type,
17511 -- the pragma is legal.
17513 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
17514 Has_OK_Formal
:= True;
17517 -- A generic subprogram with at least one formal of a private
17518 -- type ensures the legality of the pragma because the actual
17519 -- may be specifically tagged. Note that this is verified by
17520 -- the check above at instantiation time.
17522 elsif Is_Private_Type
(Etype
(Formal
))
17523 and then Is_Generic_Type
(Etype
(Formal
))
17525 Has_OK_Formal
:= True;
17529 Next_Formal
(Formal
);
17532 if not Has_OK_Formal
then
17533 Error_Msg_Name_1
:= Pname
;
17534 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
17536 ("\subprogram & lacks parameter of specific tagged or "
17537 & "generic private type", N
, Spec_Id
);
17542 -- Analyze the Boolean expression (if any)
17544 if Present
(Arg1
) then
17545 Check_Static_Boolean_Expression
17546 (Expression
(Get_Argument
(N
, Spec_Id
)));
17548 end Extensions_Visible
;
17554 -- pragma External (
17555 -- [ Convention =>] convention_IDENTIFIER,
17556 -- [ Entity =>] LOCAL_NAME
17557 -- [, [External_Name =>] static_string_EXPRESSION ]
17558 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17560 when Pragma_External
=> External
: declare
17563 pragma Warnings
(Off
, C
);
17570 Name_External_Name
,
17572 Check_At_Least_N_Arguments
(2);
17573 Check_At_Most_N_Arguments
(4);
17574 Process_Convention
(C
, E
);
17576 -- A pragma that applies to a Ghost entity becomes Ghost for the
17577 -- purposes of legality checks and removal of ignored Ghost code.
17579 Mark_Ghost_Pragma
(N
, E
);
17581 Note_Possible_Modification
17582 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
17583 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
17584 Set_Exported
(E
, Arg2
);
17587 --------------------------
17588 -- External_Name_Casing --
17589 --------------------------
17591 -- pragma External_Name_Casing (
17592 -- UPPERCASE | LOWERCASE
17593 -- [, AS_IS | UPPERCASE | LOWERCASE]);
17595 when Pragma_External_Name_Casing
=>
17597 Check_No_Identifiers
;
17599 if Arg_Count
= 2 then
17600 Check_Arg_Is_One_Of
17601 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
17603 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17605 Opt
.External_Name_Exp_Casing
:= As_Is
;
17607 when Name_Uppercase
=>
17608 Opt
.External_Name_Exp_Casing
:= Uppercase
;
17610 when Name_Lowercase
=>
17611 Opt
.External_Name_Exp_Casing
:= Lowercase
;
17618 Check_Arg_Count
(1);
17621 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
17623 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17624 when Name_Uppercase
=>
17625 Opt
.External_Name_Imp_Casing
:= Uppercase
;
17627 when Name_Lowercase
=>
17628 Opt
.External_Name_Imp_Casing
:= Lowercase
;
17638 -- pragma Fast_Math;
17640 when Pragma_Fast_Math
=>
17642 Check_No_Identifiers
;
17643 Check_Valid_Configuration_Pragma
;
17646 --------------------------
17647 -- Favor_Top_Level --
17648 --------------------------
17650 -- pragma Favor_Top_Level (type_NAME);
17652 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
17657 Check_No_Identifiers
;
17658 Check_Arg_Count
(1);
17659 Check_Arg_Is_Local_Name
(Arg1
);
17660 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
17662 -- A pragma that applies to a Ghost entity becomes Ghost for the
17663 -- purposes of legality checks and removal of ignored Ghost code.
17665 Mark_Ghost_Pragma
(N
, Typ
);
17667 -- If it's an access-to-subprogram type (in particular, not a
17668 -- subtype), set the flag on that type.
17670 if Is_Access_Subprogram_Type
(Typ
) then
17671 Set_Can_Use_Internal_Rep
(Typ
, False);
17673 -- Otherwise it's an error (name denotes the wrong sort of entity)
17677 ("access-to-subprogram type expected",
17678 Get_Pragma_Arg
(Arg1
));
17680 end Favor_Top_Level
;
17682 ---------------------------
17683 -- Finalize_Storage_Only --
17684 ---------------------------
17686 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
17688 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
17689 Assoc
: constant Node_Id
:= Arg1
;
17690 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
17695 Check_No_Identifiers
;
17696 Check_Arg_Count
(1);
17697 Check_Arg_Is_Local_Name
(Arg1
);
17699 Find_Type
(Type_Id
);
17700 Typ
:= Entity
(Type_Id
);
17703 or else Rep_Item_Too_Early
(Typ
, N
)
17707 Typ
:= Underlying_Type
(Typ
);
17710 if not Is_Controlled
(Typ
) then
17711 Error_Pragma
("pragma% must specify controlled type");
17714 Check_First_Subtype
(Arg1
);
17716 if Finalize_Storage_Only
(Typ
) then
17717 Error_Pragma
("duplicate pragma%, only one allowed");
17719 elsif not Rep_Item_Too_Late
(Typ
, N
) then
17720 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
17722 end Finalize_Storage
;
17728 -- pragma Ghost [ (boolean_EXPRESSION) ];
17730 when Pragma_Ghost
=> Ghost
: declare
17734 Orig_Stmt
: Node_Id
;
17735 Prev_Id
: Entity_Id
;
17740 Check_No_Identifiers
;
17741 Check_At_Most_N_Arguments
(1);
17745 while Present
(Stmt
) loop
17747 -- Skip prior pragmas, but check for duplicates
17749 if Nkind
(Stmt
) = N_Pragma
then
17750 if Pragma_Name
(Stmt
) = Pname
then
17757 -- Task unit declared without a definition cannot be subject to
17758 -- pragma Ghost (SPARK RM 6.9(19)).
17760 elsif Nkind
(Stmt
) in
17761 N_Single_Task_Declaration | N_Task_Type_Declaration
17763 Error_Pragma
("pragma % cannot apply to a task type");
17765 -- Skip internally generated code
17767 elsif not Comes_From_Source
(Stmt
) then
17768 Orig_Stmt
:= Original_Node
(Stmt
);
17770 -- When pragma Ghost applies to an untagged derivation, the
17771 -- derivation is transformed into a [sub]type declaration.
17774 N_Full_Type_Declaration | N_Subtype_Declaration
17775 and then Comes_From_Source
(Orig_Stmt
)
17776 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
17777 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
17778 N_Derived_Type_Definition
17780 Id
:= Defining_Entity
(Stmt
);
17783 -- When pragma Ghost applies to an object declaration which
17784 -- is initialized by means of a function call that returns
17785 -- on the secondary stack, the object declaration becomes a
17788 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
17789 and then Comes_From_Source
(Orig_Stmt
)
17790 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
17792 Id
:= Defining_Entity
(Stmt
);
17795 -- When pragma Ghost applies to an expression function, the
17796 -- expression function is transformed into a subprogram.
17798 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
17799 and then Comes_From_Source
(Orig_Stmt
)
17800 and then Nkind
(Orig_Stmt
) = N_Expression_Function
17802 Id
:= Defining_Entity
(Stmt
);
17805 -- When pragma Ghost applies to a generic formal type, the
17806 -- type declaration in the instantiation is a generated
17807 -- subtype declaration.
17809 elsif Nkind
(Stmt
) = N_Subtype_Declaration
17810 and then Present
(Generic_Parent_Type
(Stmt
))
17812 Id
:= Defining_Entity
(Stmt
);
17816 -- The pragma applies to a legal construct, stop the traversal
17818 elsif Nkind
(Stmt
) in N_Abstract_Subprogram_Declaration
17819 | N_Formal_Object_Declaration
17820 | N_Formal_Subprogram_Declaration
17821 | N_Formal_Type_Declaration
17822 | N_Full_Type_Declaration
17823 | N_Generic_Subprogram_Declaration
17824 | N_Object_Declaration
17825 | N_Private_Extension_Declaration
17826 | N_Private_Type_Declaration
17827 | N_Subprogram_Declaration
17828 | N_Subtype_Declaration
17830 Id
:= Defining_Entity
(Stmt
);
17833 -- The pragma does not apply to a legal construct, issue an
17834 -- error and stop the analysis.
17838 ("pragma % must apply to an object, package, subprogram "
17842 Stmt
:= Prev
(Stmt
);
17845 Context
:= Parent
(N
);
17847 -- Handle compilation units
17849 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17850 Context
:= Unit
(Parent
(Context
));
17853 -- Protected and task types cannot be subject to pragma Ghost
17854 -- (SPARK RM 6.9(19)).
17856 if Nkind
(Context
) in N_Protected_Body | N_Protected_Definition
17858 Error_Pragma
("pragma % cannot apply to a protected type");
17860 elsif Nkind
(Context
) in N_Task_Body | N_Task_Definition
then
17861 Error_Pragma
("pragma % cannot apply to a task type");
17866 -- When pragma Ghost is associated with a [generic] package, it
17867 -- appears in the visible declarations.
17869 if Nkind
(Context
) = N_Package_Specification
17870 and then Present
(Visible_Declarations
(Context
))
17871 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17873 Id
:= Defining_Entity
(Context
);
17875 -- Pragma Ghost applies to a stand-alone subprogram body
17877 elsif Nkind
(Context
) = N_Subprogram_Body
17878 and then No
(Corresponding_Spec
(Context
))
17880 Id
:= Defining_Entity
(Context
);
17882 -- Pragma Ghost applies to a subprogram declaration that acts
17883 -- as a compilation unit.
17885 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17886 Id
:= Defining_Entity
(Context
);
17888 -- Pragma Ghost applies to a generic subprogram
17890 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17891 Id
:= Defining_Entity
(Specification
(Context
));
17897 ("pragma % must apply to an object, package, subprogram or "
17901 -- Handle completions of types and constants that are subject to
17904 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17905 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17907 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17908 Error_Msg_Name_1
:= Pname
;
17910 -- The full declaration of a deferred constant cannot be
17911 -- subject to pragma Ghost unless the deferred declaration
17912 -- is also Ghost (SPARK RM 6.9(9)).
17914 if Ekind
(Prev_Id
) = E_Constant
then
17915 Error_Msg_Name_1
:= Pname
;
17916 Error_Msg_NE
(Fix_Error
17917 ("pragma % must apply to declaration of deferred "
17918 & "constant &"), N
, Id
);
17921 -- Pragma Ghost may appear on the full view of an incomplete
17922 -- type because the incomplete declaration lacks aspects and
17923 -- cannot be subject to pragma Ghost.
17925 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17928 -- The full declaration of a type cannot be subject to
17929 -- pragma Ghost unless the partial view is also Ghost
17930 -- (SPARK RM 6.9(9)).
17933 Error_Msg_NE
(Fix_Error
17934 ("pragma % must apply to partial view of type &"),
17940 -- A synchronized object cannot be subject to pragma Ghost
17941 -- (SPARK RM 6.9(19)).
17943 elsif Ekind
(Id
) = E_Variable
then
17944 if Is_Protected_Type
(Etype
(Id
)) then
17945 Error_Pragma
("pragma % cannot apply to a protected object");
17947 elsif Is_Task_Type
(Etype
(Id
)) then
17948 Error_Pragma
("pragma % cannot apply to a task object");
17952 -- Analyze the Boolean expression (if any)
17954 if Present
(Arg1
) then
17955 Expr
:= Get_Pragma_Arg
(Arg1
);
17957 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17959 if Is_OK_Static_Expression
(Expr
) then
17961 -- "Ghostness" cannot be turned off once enabled within a
17962 -- region (SPARK RM 6.9(6)).
17964 if Is_False
(Expr_Value
(Expr
))
17965 and then Ghost_Mode
> None
17968 ("pragma % with value False cannot appear in enabled "
17972 -- Otherwise the expression is not static
17976 ("expression of pragma % must be static", Expr
);
17980 Set_Is_Ghost_Entity
(Id
);
17987 -- pragma Global (GLOBAL_SPECIFICATION);
17989 -- GLOBAL_SPECIFICATION ::=
17992 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17994 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17996 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17997 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17998 -- GLOBAL_ITEM ::= NAME
18000 -- Characteristics:
18002 -- * Analysis - The annotation undergoes initial checks to verify
18003 -- the legal placement and context. Secondary checks fully analyze
18004 -- the dependency clauses in:
18006 -- Analyze_Global_In_Decl_Part
18008 -- * Expansion - None.
18010 -- * Template - The annotation utilizes the generic template of the
18011 -- related subprogram [body] when it is:
18013 -- aspect on subprogram declaration
18014 -- aspect on stand-alone subprogram body
18015 -- pragma on stand-alone subprogram body
18017 -- The annotation must prepare its own template when it is:
18019 -- pragma on subprogram declaration
18021 -- * Globals - Capture of global references must occur after full
18024 -- * Instance - The annotation is instantiated automatically when
18025 -- the related generic subprogram [body] is instantiated except for
18026 -- the "pragma on subprogram declaration" case. In that scenario
18027 -- the annotation must instantiate itself.
18029 when Pragma_Global
=> Global
: declare
18031 Spec_Id
: Entity_Id
;
18032 Subp_Decl
: Node_Id
;
18035 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
18039 -- Chain the pragma on the contract for further processing by
18040 -- Analyze_Global_In_Decl_Part.
18042 Add_Contract_Item
(N
, Spec_Id
);
18044 -- Fully analyze the pragma when it appears inside an entry
18045 -- or subprogram body because it cannot benefit from forward
18048 if Nkind
(Subp_Decl
) in N_Entry_Body
18049 | N_Subprogram_Body
18050 | N_Subprogram_Body_Stub
18052 -- The legality checks of pragmas Depends and Global are
18053 -- affected by the SPARK mode in effect and the volatility
18054 -- of the context. In addition these two pragmas are subject
18055 -- to an inherent order:
18060 -- Analyze all these pragmas in the order outlined above
18062 Analyze_If_Present
(Pragma_SPARK_Mode
);
18063 Analyze_If_Present
(Pragma_Volatile_Function
);
18064 Analyze_If_Present
(Pragma_Side_Effects
);
18065 Analyze_Global_In_Decl_Part
(N
);
18066 Analyze_If_Present
(Pragma_Depends
);
18075 -- pragma Ident (static_string_EXPRESSION)
18077 -- Note: pragma Comment shares this processing. Pragma Ident is
18078 -- identical in effect to pragma Commment.
18080 when Pragma_Comment
18088 Check_Arg_Count
(1);
18089 Check_No_Identifiers
;
18090 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18093 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
18100 GP
:= Parent
(Parent
(N
));
18103 N_Package_Declaration | N_Generic_Package_Declaration
18108 -- If we have a compilation unit, then record the ident value,
18109 -- checking for improper duplication.
18111 if Nkind
(GP
) = N_Compilation_Unit
then
18112 CS
:= Ident_String
(Current_Sem_Unit
);
18114 if Present
(CS
) then
18116 -- If we have multiple instances, concatenate them.
18118 Start_String
(Strval
(CS
));
18119 Store_String_Char
(' ');
18120 Store_String_Chars
(Strval
(Str
));
18121 Set_Strval
(CS
, End_String
);
18124 Set_Ident_String
(Current_Sem_Unit
, Str
);
18127 -- For subunits, we just ignore the Ident, since in GNAT these
18128 -- are not separate object files, and hence not separate units
18129 -- in the unit table.
18131 elsif Nkind
(GP
) = N_Subunit
then
18137 -------------------
18138 -- Ignore_Pragma --
18139 -------------------
18141 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
18143 -- Entirely handled in the parser, nothing to do here
18145 when Pragma_Ignore_Pragma
=>
18148 ----------------------------
18149 -- Implementation_Defined --
18150 ----------------------------
18152 -- pragma Implementation_Defined (LOCAL_NAME);
18154 -- Marks previously declared entity as implementation defined. For
18155 -- an overloaded entity, applies to the most recent homonym.
18157 -- pragma Implementation_Defined;
18159 -- The form with no arguments appears anywhere within a scope, most
18160 -- typically a package spec, and indicates that all entities that are
18161 -- defined within the package spec are Implementation_Defined.
18163 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
18168 Check_No_Identifiers
;
18170 -- Form with no arguments
18172 if Arg_Count
= 0 then
18173 Set_Is_Implementation_Defined
(Current_Scope
);
18175 -- Form with one argument
18178 Check_Arg_Count
(1);
18179 Check_Arg_Is_Local_Name
(Arg1
);
18180 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18181 Set_Is_Implementation_Defined
(Ent
);
18183 end Implementation_Defined
;
18189 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
18191 -- IMPLEMENTATION_KIND ::=
18192 -- By_Entry | By_Protected_Procedure | By_Any | Optional
18194 -- "By_Any" and "Optional" are treated as synonyms in order to
18195 -- support Ada 2012 aspect Synchronization.
18197 when Pragma_Implemented
=> Implemented
: declare
18198 Proc_Id
: Entity_Id
;
18203 Check_Arg_Count
(2);
18204 Check_No_Identifiers
;
18205 Check_Arg_Is_Identifier
(Arg1
);
18206 Check_Arg_Is_Local_Name
(Arg1
);
18207 Check_Arg_Is_One_Of
(Arg2
,
18210 Name_By_Protected_Procedure
,
18213 -- Extract the name of the local procedure
18215 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18217 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
18218 -- primitive procedure of a synchronized tagged type.
18220 if Ekind
(Proc_Id
) = E_Procedure
18221 and then Is_Primitive
(Proc_Id
)
18222 and then Present
(First_Formal
(Proc_Id
))
18224 Typ
:= Etype
(First_Formal
(Proc_Id
));
18226 if Is_Tagged_Type
(Typ
)
18229 -- Check for a protected, a synchronized or a task interface
18231 ((Is_Interface
(Typ
)
18232 and then Is_Synchronized_Interface
(Typ
))
18234 -- Check for a protected type or a task type that implements
18238 (Is_Concurrent_Record_Type
(Typ
)
18239 and then Present
(Interfaces
(Typ
)))
18241 -- In analysis-only mode, examine original protected type
18244 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
18245 and then Present
(Interface_List
(Parent
(Typ
))))
18247 -- Check for a private record extension with keyword
18251 (Ekind
(Typ
) in E_Record_Type_With_Private
18252 | E_Record_Subtype_With_Private
18253 and then Synchronized_Present
(Parent
(Typ
))))
18258 ("controlling formal must be of synchronized tagged type",
18262 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
18263 -- By_Protected_Procedure to the primitive procedure of a task
18266 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
18267 and then Is_Interface
(Typ
)
18268 and then Is_Task_Interface
(Typ
)
18271 ("implementation kind By_Protected_Procedure cannot be "
18272 & "applied to a task interface primitive", Arg2
);
18275 -- Procedures declared inside a protected type must be accepted
18277 elsif Ekind
(Proc_Id
) = E_Procedure
18278 and then Is_Protected_Type
(Scope
(Proc_Id
))
18282 -- The first argument is not a primitive procedure
18286 ("pragma % must be applied to a primitive procedure", Arg1
);
18289 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
18290 -- By_Protected_Procedure to a procedure that has aspect Yield
18292 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
18293 and then Has_Yield_Aspect
(Proc_Id
)
18296 ("implementation kind By_Protected_Procedure cannot be "
18297 & "applied to entities with aspect 'Yield", Arg2
);
18300 Record_Rep_Item
(Proc_Id
, N
);
18303 ----------------------
18304 -- Implicit_Packing --
18305 ----------------------
18307 -- pragma Implicit_Packing;
18309 when Pragma_Implicit_Packing
=>
18311 Check_Arg_Count
(0);
18312 Implicit_Packing
:= True;
18319 -- [Convention =>] convention_IDENTIFIER,
18320 -- [Entity =>] LOCAL_NAME
18321 -- [, [External_Name =>] static_string_EXPRESSION ]
18322 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18324 when Pragma_Import
=>
18325 Check_Ada_83_Warning
;
18329 Name_External_Name
,
18332 Check_At_Least_N_Arguments
(2);
18333 Check_At_Most_N_Arguments
(4);
18334 Process_Import_Or_Interface
;
18336 ---------------------
18337 -- Import_Function --
18338 ---------------------
18340 -- pragma Import_Function (
18341 -- [Internal =>] LOCAL_NAME,
18342 -- [, [External =>] EXTERNAL_SYMBOL]
18343 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18344 -- [, [Result_Type =>] SUBTYPE_MARK]
18345 -- [, [Mechanism =>] MECHANISM]
18346 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
18348 -- EXTERNAL_SYMBOL ::=
18350 -- | static_string_EXPRESSION
18352 -- PARAMETER_TYPES ::=
18354 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18356 -- TYPE_DESIGNATOR ::=
18358 -- | subtype_Name ' Access
18362 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18364 -- MECHANISM_ASSOCIATION ::=
18365 -- [formal_parameter_NAME =>] MECHANISM_NAME
18367 -- MECHANISM_NAME ::=
18371 when Pragma_Import_Function
=> Import_Function
: declare
18372 Args
: Args_List
(1 .. 6);
18373 Names
: constant Name_List
(1 .. 6) := (
18376 Name_Parameter_Types
,
18379 Name_Result_Mechanism
);
18381 Internal
: Node_Id
renames Args
(1);
18382 External
: Node_Id
renames Args
(2);
18383 Parameter_Types
: Node_Id
renames Args
(3);
18384 Result_Type
: Node_Id
renames Args
(4);
18385 Mechanism
: Node_Id
renames Args
(5);
18386 Result_Mechanism
: Node_Id
renames Args
(6);
18390 Gather_Associations
(Names
, Args
);
18391 Process_Extended_Import_Export_Subprogram_Pragma
(
18392 Arg_Internal
=> Internal
,
18393 Arg_External
=> External
,
18394 Arg_Parameter_Types
=> Parameter_Types
,
18395 Arg_Result_Type
=> Result_Type
,
18396 Arg_Mechanism
=> Mechanism
,
18397 Arg_Result_Mechanism
=> Result_Mechanism
);
18398 end Import_Function
;
18400 -------------------
18401 -- Import_Object --
18402 -------------------
18404 -- pragma Import_Object (
18405 -- [Internal =>] LOCAL_NAME
18406 -- [, [External =>] EXTERNAL_SYMBOL]
18407 -- [, [Size =>] EXTERNAL_SYMBOL]);
18409 -- EXTERNAL_SYMBOL ::=
18411 -- | static_string_EXPRESSION
18413 when Pragma_Import_Object
=> Import_Object
: declare
18414 Args
: Args_List
(1 .. 3);
18415 Names
: constant Name_List
(1 .. 3) := (
18420 Internal
: Node_Id
renames Args
(1);
18421 External
: Node_Id
renames Args
(2);
18422 Size
: Node_Id
renames Args
(3);
18426 Gather_Associations
(Names
, Args
);
18427 Process_Extended_Import_Export_Object_Pragma
(
18428 Arg_Internal
=> Internal
,
18429 Arg_External
=> External
,
18433 ----------------------
18434 -- Import_Procedure --
18435 ----------------------
18437 -- pragma Import_Procedure (
18438 -- [Internal =>] LOCAL_NAME
18439 -- [, [External =>] EXTERNAL_SYMBOL]
18440 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18441 -- [, [Mechanism =>] MECHANISM]);
18443 -- EXTERNAL_SYMBOL ::=
18445 -- | static_string_EXPRESSION
18447 -- PARAMETER_TYPES ::=
18449 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18451 -- TYPE_DESIGNATOR ::=
18453 -- | subtype_Name ' Access
18457 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18459 -- MECHANISM_ASSOCIATION ::=
18460 -- [formal_parameter_NAME =>] MECHANISM_NAME
18462 -- MECHANISM_NAME ::=
18466 when Pragma_Import_Procedure
=> Import_Procedure
: declare
18467 Args
: Args_List
(1 .. 4);
18468 Names
: constant Name_List
(1 .. 4) := (
18471 Name_Parameter_Types
,
18474 Internal
: Node_Id
renames Args
(1);
18475 External
: Node_Id
renames Args
(2);
18476 Parameter_Types
: Node_Id
renames Args
(3);
18477 Mechanism
: Node_Id
renames Args
(4);
18481 Gather_Associations
(Names
, Args
);
18482 Process_Extended_Import_Export_Subprogram_Pragma
(
18483 Arg_Internal
=> Internal
,
18484 Arg_External
=> External
,
18485 Arg_Parameter_Types
=> Parameter_Types
,
18486 Arg_Mechanism
=> Mechanism
);
18487 end Import_Procedure
;
18489 -----------------------------
18490 -- Import_Valued_Procedure --
18491 -----------------------------
18493 -- pragma Import_Valued_Procedure (
18494 -- [Internal =>] LOCAL_NAME
18495 -- [, [External =>] EXTERNAL_SYMBOL]
18496 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
18497 -- [, [Mechanism =>] MECHANISM]);
18499 -- EXTERNAL_SYMBOL ::=
18501 -- | static_string_EXPRESSION
18503 -- PARAMETER_TYPES ::=
18505 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
18507 -- TYPE_DESIGNATOR ::=
18509 -- | subtype_Name ' Access
18513 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
18515 -- MECHANISM_ASSOCIATION ::=
18516 -- [formal_parameter_NAME =>] MECHANISM_NAME
18518 -- MECHANISM_NAME ::=
18522 when Pragma_Import_Valued_Procedure
=>
18523 Import_Valued_Procedure
: declare
18524 Args
: Args_List
(1 .. 4);
18525 Names
: constant Name_List
(1 .. 4) := (
18528 Name_Parameter_Types
,
18531 Internal
: Node_Id
renames Args
(1);
18532 External
: Node_Id
renames Args
(2);
18533 Parameter_Types
: Node_Id
renames Args
(3);
18534 Mechanism
: Node_Id
renames Args
(4);
18538 Gather_Associations
(Names
, Args
);
18539 Process_Extended_Import_Export_Subprogram_Pragma
(
18540 Arg_Internal
=> Internal
,
18541 Arg_External
=> External
,
18542 Arg_Parameter_Types
=> Parameter_Types
,
18543 Arg_Mechanism
=> Mechanism
);
18544 end Import_Valued_Procedure
;
18550 -- pragma Independent (LOCAL_NAME);
18552 when Pragma_Independent
=>
18553 Process_Atomic_Independent_Shared_Volatile
;
18555 ----------------------------
18556 -- Independent_Components --
18557 ----------------------------
18559 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
18561 when Pragma_Independent_Components
=> Independent_Components
: declare
18568 Check_Ada_83_Warning
;
18570 Check_No_Identifiers
;
18571 Check_Arg_Count
(1);
18572 Check_Arg_Is_Local_Name
(Arg1
);
18573 E_Id
:= Get_Pragma_Arg
(Arg1
);
18575 if Etype
(E_Id
) = Any_Type
then
18579 E
:= Entity
(E_Id
);
18581 -- A record type with a self-referential component of anonymous
18582 -- access type is given an incomplete view in order to handle the
18585 -- type Rec is record
18586 -- Self : access Rec;
18592 -- type Ptr is access Rec;
18593 -- type Rec is record
18597 -- Since the incomplete view is now the initial view of the type,
18598 -- the argument of the pragma will reference the incomplete view,
18599 -- but this view is illegal according to the semantics of the
18602 -- Obtain the full view of an internally-generated incomplete type
18603 -- only. This way an attempt to associate the pragma with a source
18604 -- incomplete type is still caught.
18606 if Ekind
(E
) = E_Incomplete_Type
18607 and then not Comes_From_Source
(E
)
18608 and then Present
(Full_View
(E
))
18610 E
:= Full_View
(E
);
18613 -- A pragma that applies to a Ghost entity becomes Ghost for the
18614 -- purposes of legality checks and removal of ignored Ghost code.
18616 Mark_Ghost_Pragma
(N
, E
);
18618 -- Check duplicate before we chain ourselves
18620 Check_Duplicate_Pragma
(E
);
18622 -- Check appropriate entity
18624 if Rep_Item_Too_Early
(E
, N
)
18626 Rep_Item_Too_Late
(E
, N
)
18631 D
:= Declaration_Node
(E
);
18633 -- The flag is set on the base type, or on the object
18635 if Nkind
(D
) = N_Full_Type_Declaration
18636 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
18638 Set_Has_Independent_Components
(Base_Type
(E
));
18639 Record_Independence_Check
(N
, Base_Type
(E
));
18641 -- For record type, set all components independent
18643 if Is_Record_Type
(E
) then
18644 C
:= First_Component
(E
);
18645 while Present
(C
) loop
18646 Set_Is_Independent
(C
);
18647 Next_Component
(C
);
18651 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
18652 and then Nkind
(D
) = N_Object_Declaration
18653 and then Nkind
(Object_Definition
(D
)) =
18654 N_Constrained_Array_Definition
18656 Set_Has_Independent_Components
(E
);
18657 Record_Independence_Check
(N
, E
);
18660 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
18662 end Independent_Components
;
18664 -----------------------
18665 -- Initial_Condition --
18666 -----------------------
18668 -- pragma Initial_Condition (boolean_EXPRESSION);
18670 -- Characteristics:
18672 -- * Analysis - The annotation undergoes initial checks to verify
18673 -- the legal placement and context. Secondary checks preanalyze the
18676 -- Analyze_Initial_Condition_In_Decl_Part
18678 -- * Expansion - The annotation is expanded during the expansion of
18679 -- the package body whose declaration is subject to the annotation
18682 -- Expand_Pragma_Initial_Condition
18684 -- * Template - The annotation utilizes the generic template of the
18685 -- related package declaration.
18687 -- * Globals - Capture of global references must occur after full
18690 -- * Instance - The annotation is instantiated automatically when
18691 -- the related generic package is instantiated.
18693 when Pragma_Initial_Condition
=> Initial_Condition
: declare
18694 Pack_Decl
: Node_Id
;
18695 Pack_Id
: Entity_Id
;
18699 Check_No_Identifiers
;
18700 Check_Arg_Count
(1);
18702 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18704 if Nkind
(Pack_Decl
) not in
18705 N_Generic_Package_Declaration | N_Package_Declaration
18710 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18712 -- A pragma that applies to a Ghost entity becomes Ghost for the
18713 -- purposes of legality checks and removal of ignored Ghost code.
18715 Mark_Ghost_Pragma
(N
, Pack_Id
);
18717 -- Chain the pragma on the contract for further processing by
18718 -- Analyze_Initial_Condition_In_Decl_Part.
18720 Add_Contract_Item
(N
, Pack_Id
);
18722 -- The legality checks of pragmas Abstract_State, Initializes, and
18723 -- Initial_Condition are affected by the SPARK mode in effect. In
18724 -- addition, these three pragmas are subject to an inherent order:
18726 -- 1) Abstract_State
18728 -- 3) Initial_Condition
18730 -- Analyze all these pragmas in the order outlined above
18732 Analyze_If_Present
(Pragma_SPARK_Mode
);
18733 Analyze_If_Present
(Pragma_Abstract_State
);
18734 Analyze_If_Present
(Pragma_Initializes
);
18735 end Initial_Condition
;
18737 ------------------------
18738 -- Initialize_Scalars --
18739 ------------------------
18741 -- pragma Initialize_Scalars
18742 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
18744 -- TYPE_VALUE_PAIR ::=
18745 -- SCALAR_TYPE => static_EXPRESSION
18751 -- | Long_Long_Float
18763 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
18764 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
18765 -- This collection holds the individual pairs which specify the
18766 -- invalid values of their respective scalar types.
18768 procedure Analyze_Float_Value
18769 (Scal_Typ
: Float_Scalar_Id
;
18770 Val_Expr
: Node_Id
);
18771 -- Analyze a type value pair associated with float type Scal_Typ
18772 -- and expression Val_Expr.
18774 procedure Analyze_Integer_Value
18775 (Scal_Typ
: Integer_Scalar_Id
;
18776 Val_Expr
: Node_Id
);
18777 -- Analyze a type value pair associated with integer type Scal_Typ
18778 -- and expression Val_Expr.
18780 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
18781 -- Analyze type value pair Pair
18783 -------------------------
18784 -- Analyze_Float_Value --
18785 -------------------------
18787 procedure Analyze_Float_Value
18788 (Scal_Typ
: Float_Scalar_Id
;
18789 Val_Expr
: Node_Id
)
18792 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
18794 if Is_OK_Static_Expression
(Val_Expr
) then
18795 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
18798 Error_Msg_Name_1
:= Scal_Typ
;
18799 Error_Msg_N
("value for type % must be static", Val_Expr
);
18801 end Analyze_Float_Value
;
18803 ---------------------------
18804 -- Analyze_Integer_Value --
18805 ---------------------------
18807 procedure Analyze_Integer_Value
18808 (Scal_Typ
: Integer_Scalar_Id
;
18809 Val_Expr
: Node_Id
)
18812 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
18814 if (Scal_Typ
= Name_Signed_128
18815 or else Scal_Typ
= Name_Unsigned_128
)
18816 and then Ttypes
.System_Max_Integer_Size
< 128
18818 Error_Msg_Name_1
:= Scal_Typ
;
18819 Error_Msg_N
("value cannot be set for type %", Val_Expr
);
18821 elsif Is_OK_Static_Expression
(Val_Expr
) then
18822 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
18825 Error_Msg_Name_1
:= Scal_Typ
;
18826 Error_Msg_N
("value for type % must be static", Val_Expr
);
18828 end Analyze_Integer_Value
;
18830 -----------------------------
18831 -- Analyze_Type_Value_Pair --
18832 -----------------------------
18834 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
18835 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
18836 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
18837 Prev_Pair
: Node_Id
;
18840 if Scal_Typ
in Scalar_Id
then
18841 Prev_Pair
:= Seen
(Scal_Typ
);
18843 -- Prevent multiple attempts to set a value for a scalar
18846 if Present
(Prev_Pair
) then
18847 Error_Msg_Name_1
:= Scal_Typ
;
18849 ("cannot specify multiple invalid values for type %",
18852 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18853 Error_Msg_N
("previous value set #", Pair
);
18855 -- Ignore the effects of the pair, but do not halt the
18856 -- analysis of the pragma altogether.
18860 -- Otherwise capture the first pair for this scalar type
18863 Seen
(Scal_Typ
) := Pair
;
18866 if Scal_Typ
in Float_Scalar_Id
then
18867 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18869 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18870 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18873 -- Otherwise the scalar family is illegal
18876 Error_Msg_Name_1
:= Pname
;
18878 ("argument of pragma % must denote valid scalar family",
18881 end Analyze_Type_Value_Pair
;
18885 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18888 -- Start of processing for Do_Initialize_Scalars
18892 Check_Valid_Configuration_Pragma
;
18893 Check_Restriction
(No_Initialize_Scalars
, N
);
18895 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18898 if Restriction_Active
(No_Initialize_Scalars
) then
18901 -- Initialize_Scalars creates false positives in CodePeer, and
18902 -- incorrect negative results in GNATprove mode, so ignore this
18903 -- pragma in these modes.
18905 elsif CodePeer_Mode
or GNATprove_Mode
then
18908 -- Otherwise analyze the pragma
18911 if Present
(Pairs
) then
18913 -- Install Standard in order to provide access to primitive
18914 -- types in case the expressions contain attributes such as
18917 Push_Scope
(Standard_Standard
);
18919 Pair
:= First
(Pairs
);
18920 while Present
(Pair
) loop
18921 Analyze_Type_Value_Pair
(Pair
);
18930 Init_Or_Norm_Scalars
:= True;
18931 Initialize_Scalars
:= True;
18933 end Do_Initialize_Scalars
;
18939 -- pragma Initializes (INITIALIZATION_LIST);
18941 -- INITIALIZATION_LIST ::=
18943 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18945 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18950 -- | (INPUT {, INPUT})
18954 -- Characteristics:
18956 -- * Analysis - The annotation undergoes initial checks to verify
18957 -- the legal placement and context. Secondary checks preanalyze the
18960 -- Analyze_Initializes_In_Decl_Part
18962 -- * Expansion - None.
18964 -- * Template - The annotation utilizes the generic template of the
18965 -- related package declaration.
18967 -- * Globals - Capture of global references must occur after full
18970 -- * Instance - The annotation is instantiated automatically when
18971 -- the related generic package is instantiated.
18973 when Pragma_Initializes
=> Initializes
: declare
18974 Pack_Decl
: Node_Id
;
18975 Pack_Id
: Entity_Id
;
18979 Check_No_Identifiers
;
18980 Check_Arg_Count
(1);
18982 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18984 if Nkind
(Pack_Decl
) not in
18985 N_Generic_Package_Declaration | N_Package_Declaration
18990 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18992 -- A pragma that applies to a Ghost entity becomes Ghost for the
18993 -- purposes of legality checks and removal of ignored Ghost code.
18995 Mark_Ghost_Pragma
(N
, Pack_Id
);
18996 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18998 -- Chain the pragma on the contract for further processing by
18999 -- Analyze_Initializes_In_Decl_Part.
19001 Add_Contract_Item
(N
, Pack_Id
);
19003 -- The legality checks of pragmas Abstract_State, Initializes, and
19004 -- Initial_Condition are affected by the SPARK mode in effect. In
19005 -- addition, these three pragmas are subject to an inherent order:
19007 -- 1) Abstract_State
19009 -- 3) Initial_Condition
19011 -- Analyze all these pragmas in the order outlined above
19013 Analyze_If_Present
(Pragma_SPARK_Mode
);
19014 Analyze_If_Present
(Pragma_Abstract_State
);
19015 Analyze_If_Present
(Pragma_Initial_Condition
);
19022 -- pragma Inline ( NAME {, NAME} );
19024 when Pragma_Inline
=>
19026 -- Pragma always active unless in GNATprove mode. It is disabled
19027 -- in GNATprove mode because frontend inlining is applied
19028 -- independently of pragmas Inline and Inline_Always for
19029 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
19032 if not GNATprove_Mode
then
19034 -- Inline status is Enabled if option -gnatn is specified.
19035 -- However this status determines only the value of the
19036 -- Is_Inlined flag on the subprogram and does not prevent
19037 -- the pragma itself from being recorded for later use,
19038 -- in particular for a later modification of Is_Inlined
19039 -- independently of the -gnatn option.
19041 -- In other words, if -gnatn is specified for a unit, then
19042 -- all Inline pragmas processed for the compilation of this
19043 -- unit, including those in the spec of other units, are
19044 -- activated, so subprograms will be inlined across units.
19046 -- If -gnatn is not specified, no Inline pragma is activated
19047 -- here, which means that subprograms will not be inlined
19048 -- across units. The Is_Inlined flag will nevertheless be
19049 -- set later when bodies are analyzed, so subprograms will
19050 -- be inlined within the unit.
19052 if Inline_Active
then
19053 Process_Inline
(Enabled
);
19055 Process_Inline
(Disabled
);
19059 -------------------
19060 -- Inline_Always --
19061 -------------------
19063 -- pragma Inline_Always ( NAME {, NAME} );
19065 when Pragma_Inline_Always
=>
19068 -- Pragma always active unless in CodePeer mode or GNATprove
19069 -- mode. It is disabled in CodePeer mode because inlining is
19070 -- not helpful, and enabling it caused walk order issues. It
19071 -- is disabled in GNATprove mode because frontend inlining is
19072 -- applied independently of pragmas Inline and Inline_Always for
19073 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
19076 if not CodePeer_Mode
and not GNATprove_Mode
then
19077 Process_Inline
(Enabled
);
19080 --------------------
19081 -- Inline_Generic --
19082 --------------------
19084 -- pragma Inline_Generic (NAME {, NAME});
19086 when Pragma_Inline_Generic
=>
19088 Process_Generic_List
;
19090 ----------------------
19091 -- Inspection_Point --
19092 ----------------------
19094 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
19096 when Pragma_Inspection_Point
=> Inspection_Point
: declare
19103 if Arg_Count
> 0 then
19106 Exp
:= Get_Pragma_Arg
(Arg
);
19109 if not Is_Entity_Name
(Exp
)
19110 or else not Is_Object
(Entity
(Exp
))
19112 Error_Pragma_Arg
("object name required", Arg
);
19116 exit when No
(Arg
);
19119 end Inspection_Point
;
19125 -- pragma Interface (
19126 -- [ Convention =>] convention_IDENTIFIER,
19127 -- [ Entity =>] LOCAL_NAME
19128 -- [, [External_Name =>] static_string_EXPRESSION ]
19129 -- [, [Link_Name =>] static_string_EXPRESSION ]);
19131 when Pragma_Interface
=>
19136 Name_External_Name
,
19138 Check_At_Least_N_Arguments
(2);
19139 Check_At_Most_N_Arguments
(4);
19140 Process_Import_Or_Interface
;
19142 -- In Ada 2005, the permission to use Interface (a reserved word)
19143 -- as a pragma name is considered an obsolescent feature, and this
19144 -- pragma was already obsolescent in Ada 95.
19146 if Ada_Version
>= Ada_95
then
19148 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
19150 if Warn_On_Obsolescent_Feature
then
19152 ("pragma Interface is an obsolescent feature?j?", N
);
19154 ("|use pragma Import instead?j?", N
);
19158 --------------------
19159 -- Interface_Name --
19160 --------------------
19162 -- pragma Interface_Name (
19163 -- [ Entity =>] LOCAL_NAME
19164 -- [,[External_Name =>] static_string_EXPRESSION ]
19165 -- [,[Link_Name =>] static_string_EXPRESSION ]);
19167 when Pragma_Interface_Name
=> Interface_Name
: declare
19169 Def_Id
: Entity_Id
;
19170 Hom_Id
: Entity_Id
;
19176 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
19177 Check_At_Least_N_Arguments
(2);
19178 Check_At_Most_N_Arguments
(3);
19179 Id
:= Get_Pragma_Arg
(Arg1
);
19182 -- This is obsolete from Ada 95 on, but it is an implementation
19183 -- defined pragma, so we do not consider that it violates the
19184 -- restriction (No_Obsolescent_Features).
19186 if Ada_Version
>= Ada_95
then
19187 if Warn_On_Obsolescent_Feature
then
19189 ("pragma Interface_Name is an obsolescent feature?j?", N
);
19191 ("|use pragma Import instead?j?", N
);
19195 if not Is_Entity_Name
(Id
) then
19197 ("first argument for pragma% must be entity name", Arg1
);
19198 elsif Etype
(Id
) = Any_Type
then
19201 Def_Id
:= Entity
(Id
);
19204 -- Special DEC-compatible processing for the object case, forces
19205 -- object to be imported.
19207 if Ekind
(Def_Id
) = E_Variable
then
19208 Kill_Size_Check_Code
(Def_Id
);
19209 Note_Possible_Modification
(Id
, Sure
=> False);
19211 -- Initialization is not allowed for imported variable
19213 if Present
(Expression
(Parent
(Def_Id
)))
19214 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
19216 Error_Msg_Sloc
:= Sloc
(Def_Id
);
19218 ("no initialization allowed for declaration of& #",
19222 -- For compatibility, support VADS usage of providing both
19223 -- pragmas Interface and Interface_Name to obtain the effect
19224 -- of a single Import pragma.
19226 if Is_Imported
(Def_Id
)
19227 and then Present
(First_Rep_Item
(Def_Id
))
19228 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
19229 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
19234 Set_Imported
(Def_Id
);
19237 Set_Is_Public
(Def_Id
);
19238 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
19241 -- Otherwise must be subprogram
19243 elsif not Is_Subprogram
(Def_Id
) then
19245 ("argument of pragma% is not subprogram", Arg1
);
19248 Check_At_Most_N_Arguments
(3);
19252 -- Loop through homonyms
19255 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
19257 if Is_Imported
(Def_Id
) then
19258 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
19262 exit when From_Aspect_Specification
(N
);
19263 Hom_Id
:= Homonym
(Hom_Id
);
19265 exit when No
(Hom_Id
)
19266 or else Scope
(Hom_Id
) /= Current_Scope
;
19271 ("argument of pragma% is not imported subprogram",
19275 end Interface_Name
;
19277 -----------------------
19278 -- Interrupt_Handler --
19279 -----------------------
19281 -- pragma Interrupt_Handler (handler_NAME);
19283 when Pragma_Interrupt_Handler
=>
19284 Check_Ada_83_Warning
;
19285 Check_Arg_Count
(1);
19286 Check_No_Identifiers
;
19288 if No_Run_Time_Mode
then
19289 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
19291 Check_Interrupt_Or_Attach_Handler
;
19292 Process_Interrupt_Or_Attach_Handler
;
19295 ------------------------
19296 -- Interrupt_Priority --
19297 ------------------------
19299 -- pragma Interrupt_Priority [(EXPRESSION)];
19301 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
19302 P
: constant Node_Id
:= Parent
(N
);
19307 Check_Ada_83_Warning
;
19309 if Arg_Count
/= 0 then
19310 Arg
:= Get_Pragma_Arg
(Arg1
);
19311 Check_Arg_Count
(1);
19312 Check_No_Identifiers
;
19314 -- The expression must be analyzed in the special manner
19315 -- described in "Handling of Default and Per-Object
19316 -- Expressions" in sem.ads.
19318 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
19321 if Nkind
(P
) not in N_Task_Definition | N_Protected_Definition
then
19325 Ent
:= Defining_Identifier
(Parent
(P
));
19327 -- Check duplicate pragma before we chain the pragma in the Rep
19328 -- Item chain of Ent.
19330 Check_Duplicate_Pragma
(Ent
);
19331 Record_Rep_Item
(Ent
, N
);
19333 -- Check the No_Task_At_Interrupt_Priority restriction
19335 if Nkind
(P
) = N_Task_Definition
then
19336 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
19339 end Interrupt_Priority
;
19341 ---------------------
19342 -- Interrupt_State --
19343 ---------------------
19345 -- pragma Interrupt_State (
19346 -- [Name =>] INTERRUPT_ID,
19347 -- [State =>] INTERRUPT_STATE);
19349 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
19350 -- INTERRUPT_STATE => System | Runtime | User
19352 -- Note: if the interrupt id is given as an identifier, then it must
19353 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
19354 -- given as a static integer expression which must be in the range of
19355 -- Ada.Interrupts.Interrupt_ID.
19357 when Pragma_Interrupt_State
=> Interrupt_State
: declare
19358 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
19359 -- This is the entity Ada.Interrupts.Interrupt_ID;
19361 State_Type
: Character;
19362 -- Set to 's'/'r'/'u' for System/Runtime/User
19365 -- Index to entry in Interrupt_States table
19368 -- Value of interrupt
19370 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19371 -- The first argument to the pragma
19373 Int_Ent
: Entity_Id
;
19374 -- Interrupt entity in Ada.Interrupts.Names
19378 Check_Arg_Order
((Name_Name
, Name_State
));
19379 Check_Arg_Count
(2);
19381 Check_Optional_Identifier
(Arg1
, Name_Name
);
19382 Check_Optional_Identifier
(Arg2
, Name_State
);
19383 Check_Arg_Is_Identifier
(Arg2
);
19385 -- First argument is identifier
19387 if Nkind
(Arg1X
) = N_Identifier
then
19389 -- Search list of names in Ada.Interrupts.Names
19391 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
19393 if No
(Int_Ent
) then
19394 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
19396 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
19397 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
19401 Next_Entity
(Int_Ent
);
19404 -- First argument is not an identifier, so it must be a static
19405 -- expression of type Ada.Interrupts.Interrupt_ID.
19408 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
19409 Int_Val
:= Expr_Value
(Arg1X
);
19411 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
19413 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
19416 ("value not in range of type "
19417 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
19423 case Chars
(Get_Pragma_Arg
(Arg2
)) is
19424 when Name_Runtime
=> State_Type
:= 'r';
19425 when Name_System
=> State_Type
:= 's';
19426 when Name_User
=> State_Type
:= 'u';
19429 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
19432 -- Check if entry is already stored
19434 IST_Num
:= Interrupt_States
.First
;
19436 -- If entry not found, add it
19438 if IST_Num
> Interrupt_States
.Last
then
19439 Interrupt_States
.Append
19440 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
19441 Interrupt_State
=> State_Type
,
19442 Pragma_Loc
=> Loc
));
19445 -- Case of entry for the same entry
19447 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
19450 -- If state matches, done, no need to make redundant entry
19453 State_Type
= Interrupt_States
.Table
(IST_Num
).
19456 -- Otherwise if state does not match, error
19459 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
19461 ("state conflicts with that given #", Arg2
);
19464 IST_Num
:= IST_Num
+ 1;
19466 end Interrupt_State
;
19472 -- pragma Invariant
19473 -- ([Entity =>] type_LOCAL_NAME,
19474 -- [Check =>] EXPRESSION
19475 -- [,[Message =>] String_Expression]);
19477 when Pragma_Invariant
=> Invariant
: declare
19484 Check_At_Least_N_Arguments
(2);
19485 Check_At_Most_N_Arguments
(3);
19486 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19487 Check_Optional_Identifier
(Arg2
, Name_Check
);
19489 if Arg_Count
= 3 then
19490 Check_Optional_Identifier
(Arg3
, Name_Message
);
19491 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
19494 Check_Arg_Is_Local_Name
(Arg1
);
19496 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
19497 Find_Type
(Typ_Arg
);
19498 Typ
:= Entity
(Typ_Arg
);
19500 -- Nothing to do of the related type is erroneous in some way
19502 if Typ
= Any_Type
then
19505 -- AI12-0041: Invariants are allowed in interface types
19507 elsif Is_Interface
(Typ
) then
19510 -- An invariant must apply to a private type, or appear in the
19511 -- private part of a package spec and apply to a completion.
19512 -- a class-wide invariant can only appear on a private declaration
19513 -- or private extension, not a completion.
19515 -- A [class-wide] invariant may be associated a [limited] private
19516 -- type or a private extension.
19518 elsif Ekind
(Typ
) in E_Limited_Private_Type
19520 | E_Record_Type_With_Private
19524 -- A non-class-wide invariant may be associated with the full view
19525 -- of a [limited] private type or a private extension.
19527 elsif Has_Private_Declaration
(Typ
)
19528 and then not Class_Present
(N
)
19532 -- A class-wide invariant may appear on the partial view only
19534 elsif Class_Present
(N
) then
19536 ("pragma % only allowed for private type", Arg1
);
19538 -- A regular invariant may appear on both views
19542 ("pragma % only allowed for private type or corresponding "
19543 & "full view", Arg1
);
19546 -- An invariant associated with an abstract type (this includes
19547 -- interfaces) must be class-wide.
19549 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
19551 ("pragma % not allowed for abstract type", Arg1
);
19554 -- A pragma that applies to a Ghost entity becomes Ghost for the
19555 -- purposes of legality checks and removal of ignored Ghost code.
19557 Mark_Ghost_Pragma
(N
, Typ
);
19559 -- The pragma defines a type-specific invariant, the type is said
19560 -- to have invariants of its "own".
19562 Set_Has_Own_Invariants
(Base_Type
(Typ
));
19564 -- If the invariant is class-wide, then it can be inherited by
19565 -- derived or interface implementing types. The type is said to
19566 -- have "inheritable" invariants.
19568 if Class_Present
(N
) then
19569 Set_Has_Inheritable_Invariants
(Typ
);
19572 -- Chain the pragma on to the rep item chain, for processing when
19573 -- the type is frozen.
19575 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19577 -- Create the declaration of the invariant procedure that will
19578 -- verify the invariant at run time. Interfaces are treated as the
19579 -- partial view of a private type in order to achieve uniformity
19580 -- with the general case. As a result, an interface receives only
19581 -- a "partial" invariant procedure, which is never called.
19583 Build_Invariant_Procedure_Declaration
19585 Partial_Invariant
=> Is_Interface
(Typ
));
19592 -- pragma Keep_Names ([On => ] LOCAL_NAME);
19594 when Pragma_Keep_Names
=> Keep_Names
: declare
19599 Check_Arg_Count
(1);
19600 Check_Optional_Identifier
(Arg1
, Name_On
);
19601 Check_Arg_Is_Local_Name
(Arg1
);
19603 Arg
:= Get_Pragma_Arg
(Arg1
);
19606 if Etype
(Arg
) = Any_Type
then
19610 if not Is_Entity_Name
(Arg
)
19611 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
19614 ("pragma% requires a local enumeration type", Arg1
);
19617 Set_Discard_Names
(Entity
(Arg
), False);
19624 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
19626 when Pragma_License
=>
19629 -- Do not analyze pragma any further in CodePeer mode, to avoid
19630 -- extraneous errors in this implementation-dependent pragma,
19631 -- which has a different profile on other compilers.
19633 if CodePeer_Mode
then
19637 Check_Arg_Count
(1);
19638 Check_No_Identifiers
;
19639 Check_Valid_Configuration_Pragma
;
19640 Check_Arg_Is_Identifier
(Arg1
);
19643 Sind
: constant Source_File_Index
:=
19644 Source_Index
(Current_Sem_Unit
);
19647 case Chars
(Get_Pragma_Arg
(Arg1
)) is
19649 Set_License
(Sind
, GPL
);
19651 when Name_Modified_GPL
=>
19652 Set_License
(Sind
, Modified_GPL
);
19654 when Name_Restricted
=>
19655 Set_License
(Sind
, Restricted
);
19657 when Name_Unrestricted
=>
19658 Set_License
(Sind
, Unrestricted
);
19661 Error_Pragma_Arg
("invalid license name", Arg1
);
19669 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
19671 when Pragma_Link_With
=> Link_With
: declare
19677 if Operating_Mode
= Generate_Code
19678 and then In_Extended_Main_Source_Unit
(N
)
19680 Check_At_Least_N_Arguments
(1);
19681 Check_No_Identifiers
;
19682 Check_Is_In_Decl_Part_Or_Package_Spec
;
19683 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19687 while Present
(Arg
) loop
19688 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19690 -- Store argument, converting sequences of spaces to a
19691 -- single null character (this is one of the differences
19692 -- in processing between Link_With and Linker_Options).
19694 Arg_Store
: declare
19695 C
: constant Char_Code
:= Get_Char_Code
(' ');
19696 S
: constant String_Id
:=
19697 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
19698 L
: constant Nat
:= String_Length
(S
);
19701 procedure Skip_Spaces
;
19702 -- Advance F past any spaces
19708 procedure Skip_Spaces
is
19710 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
19715 -- Start of processing for Arg_Store
19718 Skip_Spaces
; -- skip leading spaces
19720 -- Loop through characters, changing any embedded
19721 -- sequence of spaces to a single null character (this
19722 -- is how Link_With/Linker_Options differ)
19725 if Get_String_Char
(S
, F
) = C
then
19728 Store_String_Char
(ASCII
.NUL
);
19731 Store_String_Char
(Get_String_Char
(S
, F
));
19739 if Present
(Arg
) then
19740 Store_String_Char
(ASCII
.NUL
);
19744 Store_Linker_Option_String
(End_String
);
19752 -- pragma Linker_Alias (
19753 -- [Entity =>] LOCAL_NAME
19754 -- [Target =>] static_string_EXPRESSION);
19756 when Pragma_Linker_Alias
=>
19758 Check_Arg_Order
((Name_Entity
, Name_Target
));
19759 Check_Arg_Count
(2);
19760 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19761 Check_Optional_Identifier
(Arg2
, Name_Target
);
19762 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19763 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19765 -- The only processing required is to link this item on to the
19766 -- list of rep items for the given entity. This is accomplished
19767 -- by the call to Rep_Item_Too_Late (when no error is detected
19768 -- and False is returned).
19770 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
19773 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19776 ------------------------
19777 -- Linker_Constructor --
19778 ------------------------
19780 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19782 -- Code is shared with Linker_Destructor
19784 -----------------------
19785 -- Linker_Destructor --
19786 -----------------------
19788 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19790 when Pragma_Linker_Constructor
19791 | Pragma_Linker_Destructor
19793 Linker_Constructor
: declare
19799 Check_Arg_Count
(1);
19800 Check_No_Identifiers
;
19801 Check_Arg_Is_Local_Name
(Arg1
);
19802 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
19804 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
19806 if not Is_Library_Level_Entity
(Proc
) then
19808 ("argument for pragma% must be library level entity", Arg1
);
19811 -- The only processing required is to link this item on to the
19812 -- list of rep items for the given entity. This is accomplished
19813 -- by the call to Rep_Item_Too_Late (when no error is detected
19814 -- and False is returned).
19816 if Rep_Item_Too_Late
(Proc
, N
) then
19819 Set_Has_Gigi_Rep_Item
(Proc
);
19821 end Linker_Constructor
;
19823 --------------------
19824 -- Linker_Options --
19825 --------------------
19827 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19829 when Pragma_Linker_Options
=> Linker_Options
: declare
19833 Check_Ada_83_Warning
;
19834 Check_No_Identifiers
;
19835 Check_Arg_Count
(1);
19836 Check_Is_In_Decl_Part_Or_Package_Spec
;
19837 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19838 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
19841 while Present
(Arg
) loop
19842 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19843 Store_String_Char
(ASCII
.NUL
);
19845 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19849 if Operating_Mode
= Generate_Code
19850 and then In_Extended_Main_Source_Unit
(N
)
19852 Store_Linker_Option_String
(End_String
);
19854 end Linker_Options
;
19856 --------------------
19857 -- Linker_Section --
19858 --------------------
19860 -- pragma Linker_Section (
19861 -- [Entity =>] LOCAL_NAME
19862 -- [Section =>] static_string_EXPRESSION);
19864 when Pragma_Linker_Section
=> Linker_Section
: declare
19869 Ghost_Error_Posted
: Boolean := False;
19870 -- Flag set when an error concerning the illegal mix of Ghost and
19871 -- non-Ghost subprograms is emitted.
19873 Ghost_Id
: Entity_Id
:= Empty
;
19874 -- The entity of the first Ghost subprogram encountered while
19875 -- processing the arguments of the pragma.
19879 Check_Arg_Order
((Name_Entity
, Name_Section
));
19880 Check_Arg_Count
(2);
19881 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19882 Check_Optional_Identifier
(Arg2
, Name_Section
);
19883 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19884 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19886 -- Check kind of entity
19888 Arg
:= Get_Pragma_Arg
(Arg1
);
19889 Ent
:= Entity
(Arg
);
19891 case Ekind
(Ent
) is
19893 -- Objects (constants and variables) and types. For these cases
19894 -- all we need to do is to set the Linker_Section_pragma field,
19895 -- checking that we do not have a duplicate.
19901 LPE
:= Linker_Section_Pragma
(Ent
);
19903 if Present
(LPE
) then
19904 Error_Msg_Sloc
:= Sloc
(LPE
);
19906 ("Linker_Section already specified for &#", Arg1
, Ent
);
19909 Set_Linker_Section_Pragma
(Ent
, N
);
19911 -- A pragma that applies to a Ghost entity becomes Ghost for
19912 -- the purposes of legality checks and removal of ignored
19915 Mark_Ghost_Pragma
(N
, Ent
);
19919 when Subprogram_Kind
=>
19921 -- Aspect case, entity already set
19923 if From_Aspect_Specification
(N
) then
19924 Set_Linker_Section_Pragma
19925 (Entity
(Corresponding_Aspect
(N
)), N
);
19927 -- Propagate it to its ultimate aliased entity to
19928 -- facilitate the backend processing this attribute
19929 -- in instantiations of generic subprograms.
19931 if Present
(Alias
(Entity
(Corresponding_Aspect
(N
))))
19933 Set_Linker_Section_Pragma
19935 (Entity
(Corresponding_Aspect
(N
))), N
);
19938 -- Pragma case, we must climb the homonym chain, but skip
19939 -- any for which the linker section is already set.
19943 if No
(Linker_Section_Pragma
(Ent
)) then
19944 Set_Linker_Section_Pragma
(Ent
, N
);
19946 -- Propagate it to its ultimate aliased entity to
19947 -- facilitate the backend processing this attribute
19948 -- in instantiations of generic subprograms.
19950 if Present
(Alias
(Ent
)) then
19951 Set_Linker_Section_Pragma
19952 (Ultimate_Alias
(Ent
), N
);
19955 -- A pragma that applies to a Ghost entity becomes
19956 -- Ghost for the purposes of legality checks and
19957 -- removal of ignored Ghost code.
19959 Mark_Ghost_Pragma
(N
, Ent
);
19961 -- Capture the entity of the first Ghost subprogram
19962 -- being processed for error detection purposes.
19964 if Is_Ghost_Entity
(Ent
) then
19965 if No
(Ghost_Id
) then
19969 -- Otherwise the subprogram is non-Ghost. It is
19970 -- illegal to mix references to Ghost and non-Ghost
19971 -- entities (SPARK RM 6.9).
19973 elsif Present
(Ghost_Id
)
19974 and then not Ghost_Error_Posted
19976 Ghost_Error_Posted
:= True;
19978 Error_Msg_Name_1
:= Pname
;
19980 ("pragma % cannot mention ghost and "
19981 & "non-ghost subprograms", N
);
19983 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19985 ("\& # declared as ghost", N
, Ghost_Id
);
19987 Error_Msg_Sloc
:= Sloc
(Ent
);
19989 ("\& # declared as non-ghost", N
, Ent
);
19993 Ent
:= Homonym
(Ent
);
19995 or else Scope
(Ent
) /= Current_Scope
;
19999 -- All other cases are illegal
20003 ("pragma% applies only to objects, subprograms, and types",
20006 end Linker_Section
;
20012 -- pragma List (On | Off)
20014 -- There is nothing to do here, since we did all the processing for
20015 -- this pragma in Par.Prag (so that it works properly even in syntax
20018 when Pragma_List
=>
20025 -- pragma Lock_Free [(Boolean_EXPRESSION)];
20027 when Pragma_Lock_Free
=> Lock_Free
: declare
20028 P
: constant Node_Id
:= Parent
(N
);
20034 Check_No_Identifiers
;
20035 Check_At_Most_N_Arguments
(1);
20037 -- Protected definition case
20039 if Nkind
(P
) = N_Protected_Definition
then
20040 Ent
:= Defining_Identifier
(Parent
(P
));
20044 if Arg_Count
= 1 then
20045 Arg
:= Get_Pragma_Arg
(Arg1
);
20046 Val
:= Is_True
(Static_Boolean
(Arg
));
20048 -- No arguments (expression is considered to be True)
20054 -- Check duplicate pragma before we chain the pragma in the Rep
20055 -- Item chain of Ent.
20057 Check_Duplicate_Pragma
(Ent
);
20058 Record_Rep_Item
(Ent
, N
);
20059 Set_Uses_Lock_Free
(Ent
, Val
);
20061 -- Anything else is incorrect placement
20068 --------------------
20069 -- Locking_Policy --
20070 --------------------
20072 -- pragma Locking_Policy (policy_IDENTIFIER);
20074 when Pragma_Locking_Policy
=> declare
20075 subtype LP_Range
is Name_Id
20076 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
20081 Check_Ada_83_Warning
;
20082 Check_Arg_Count
(1);
20083 Check_No_Identifiers
;
20084 Check_Arg_Is_Locking_Policy
(Arg1
);
20085 Check_Valid_Configuration_Pragma
;
20086 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20089 when Name_Ceiling_Locking
=> LP
:= 'C';
20090 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
20091 when Name_Inheritance_Locking
=> LP
:= 'I';
20094 if Locking_Policy
/= ' '
20095 and then Locking_Policy
/= LP
20097 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20098 Error_Pragma
("locking policy incompatible with policy#");
20100 -- Set new policy, but always preserve System_Location since we
20101 -- like the error message with the run time name.
20104 Locking_Policy
:= LP
;
20106 if Locking_Policy_Sloc
/= System_Location
then
20107 Locking_Policy_Sloc
:= Loc
;
20112 -------------------
20113 -- Loop_Optimize --
20114 -------------------
20116 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
20118 -- OPTIMIZATION_HINT ::=
20119 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
20121 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
20126 Check_At_Least_N_Arguments
(1);
20127 Check_No_Identifiers
;
20129 Hint
:= First
(Pragma_Argument_Associations
(N
));
20130 while Present
(Hint
) loop
20131 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
20139 Check_Loop_Pragma_Placement
;
20146 -- pragma Loop_Variant
20147 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
20149 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
20151 -- CHANGE_DIRECTION ::= Increases | Decreases
20153 when Pragma_Loop_Variant
=> Loop_Variant
: declare
20158 Check_At_Least_N_Arguments
(1);
20159 Check_Loop_Pragma_Placement
;
20161 -- Process all increasing / decreasing expressions
20163 Variant
:= First
(Pragma_Argument_Associations
(N
));
20164 while Present
(Variant
) loop
20165 if Chars
(Variant
) = No_Name
then
20166 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
20168 elsif Chars
(Variant
) not in
20169 Name_Decreases | Name_Increases | Name_Structural
20172 Name
: String := Get_Name_String
(Chars
(Variant
));
20175 -- It is a common mistake to write "Increasing" for
20176 -- "Increases" or "Decreasing" for "Decreases". Recognize
20177 -- specially names starting with "incr" or "decr" to
20178 -- suggest the corresponding name.
20180 System
.Case_Util
.To_Lower
(Name
);
20182 if Name
'Length >= 4
20183 and then Name
(1 .. 4) = "incr"
20185 Error_Pragma_Arg_Ident
20186 ("expect name `Increases`", Variant
);
20188 elsif Name
'Length >= 4
20189 and then Name
(1 .. 4) = "decr"
20191 Error_Pragma_Arg_Ident
20192 ("expect name `Decreases`", Variant
);
20194 elsif Name
'Length >= 4
20195 and then Name
(1 .. 4) = "stru"
20197 Error_Pragma_Arg_Ident
20198 ("expect name `Structural`", Variant
);
20201 Error_Pragma_Arg_Ident
20202 ("expect name `Increases`, `Decreases`,"
20203 & " or `Structural`", Variant
);
20207 elsif Chars
(Variant
) = Name_Structural
20208 and then List_Length
(Pragma_Argument_Associations
(N
)) > 1
20210 Error_Pragma_Arg_Ident
20211 ("Structural variant shall be the only variant", Variant
);
20214 -- Preanalyze_Assert_Expression, but without enforcing any of
20215 -- the two acceptable types.
20217 Preanalyze_Assert_Expression
(Expression
(Variant
));
20219 -- Expression of a discrete type is allowed. Nothing to
20220 -- check for structural variants.
20222 if Chars
(Variant
) = Name_Structural
20223 or else Is_Discrete_Type
(Etype
(Expression
(Variant
)))
20227 -- Expression of a Big_Integer type (or its ghost variant) is
20228 -- only allowed in Decreases clause.
20231 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
20234 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
20237 if Chars
(Variant
) = Name_Increases
then
20239 ("Loop_Variant with Big_Integer can only decrease",
20240 Expression
(Variant
));
20243 -- Expression of other types is not allowed
20247 ("expected a discrete or Big_Integer type",
20248 Expression
(Variant
));
20255 -----------------------
20256 -- Machine_Attribute --
20257 -----------------------
20259 -- pragma Machine_Attribute (
20260 -- [Entity =>] LOCAL_NAME,
20261 -- [Attribute_Name =>] static_string_EXPRESSION
20262 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
20264 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
20266 Def_Id
: Entity_Id
;
20270 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
20272 if Arg_Count
>= 3 then
20273 Check_Optional_Identifier
(Arg3
, Name_Info
);
20275 while Present
(Arg
) loop
20276 Check_Arg_Is_OK_Static_Expression
(Arg
);
20280 Check_Arg_Count
(2);
20283 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20284 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
20285 Check_Arg_Is_Local_Name
(Arg1
);
20286 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
20287 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
20289 -- Apply the pragma to the designated type, rather than to the
20290 -- access type, unless it's a strub annotation. We wish to enable
20291 -- objects of access type, as well as access types themselves, to
20292 -- be annotated, so that reading the access objects (as oposed to
20293 -- the designated data) automatically enables stack
20294 -- scrubbing. That said, as in the attribute handler that
20295 -- processes the pragma turned into a compiler attribute, a strub
20296 -- annotation that must be associated with a subprogram type (for
20297 -- holding an explicit strub mode), when applied to an
20298 -- access-to-subprogram, gets promoted to the subprogram type. We
20299 -- might be tempted to leave it alone here, since the C attribute
20300 -- handler will adjust it, but then GNAT would convert the
20301 -- annotated subprogram types to naked ones before using them,
20302 -- cancelling out their intended effects.
20304 if Is_Access_Type
(Def_Id
)
20305 and then (not Strub_Pragma_P
(N
)
20309 Ekind
(Designated_Type
20310 (Def_Id
)) = E_Subprogram_Type
))
20312 Def_Id
:= Designated_Type
(Def_Id
);
20315 if Rep_Item_Too_Early
(Def_Id
, N
) then
20319 Def_Id
:= Underlying_Type
(Def_Id
);
20321 -- The only processing required is to link this item on to the
20322 -- list of rep items for the given entity. This is accomplished
20323 -- by the call to Rep_Item_Too_Late (when no error is detected
20324 -- and False is returned).
20326 if Rep_Item_Too_Late
(Def_Id
, N
) then
20329 Set_Has_Gigi_Rep_Item
(Def_Id
);
20331 end Machine_Attribute
;
20338 -- (MAIN_OPTION [, MAIN_OPTION]);
20341 -- [STACK_SIZE =>] static_integer_EXPRESSION
20342 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
20343 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
20345 when Pragma_Main
=> Main
: declare
20346 Args
: Args_List
(1 .. 3);
20347 Names
: constant Name_List
(1 .. 3) := (
20349 Name_Task_Stack_Size_Default
,
20350 Name_Time_Slicing_Enabled
);
20356 Gather_Associations
(Names
, Args
);
20358 for J
in 1 .. 2 loop
20359 if Present
(Args
(J
)) then
20360 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
20364 if Present
(Args
(3)) then
20365 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
20369 while Present
(Nod
) loop
20370 if Nkind
(Nod
) = N_Pragma
20371 and then Pragma_Name
(Nod
) = Name_Main
20373 Error_Msg_Name_1
:= Pname
;
20374 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20385 -- pragma Main_Storage
20386 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
20388 -- MAIN_STORAGE_OPTION ::=
20389 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
20390 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
20392 when Pragma_Main_Storage
=> Main_Storage
: declare
20393 Args
: Args_List
(1 .. 2);
20394 Names
: constant Name_List
(1 .. 2) := (
20395 Name_Working_Storage
,
20402 Gather_Associations
(Names
, Args
);
20404 for J
in 1 .. 2 loop
20405 if Present
(Args
(J
)) then
20406 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
20410 Check_In_Main_Program
;
20413 while Present
(Nod
) loop
20414 if Nkind
(Nod
) = N_Pragma
20415 and then Pragma_Name
(Nod
) = Name_Main_Storage
20417 Error_Msg_Name_1
:= Pname
;
20418 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
20425 ----------------------------
20426 -- Max_Entry_Queue_Length --
20427 ----------------------------
20429 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
20431 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
20432 -- Pragma_Max_Queue_Length.
20434 when Pragma_Max_Entry_Queue_Length
20435 | Pragma_Max_Entry_Queue_Depth
20436 | Pragma_Max_Queue_Length
20438 Max_Entry_Queue_Length
: declare
20440 Entry_Decl
: Node_Id
;
20441 Entry_Id
: Entity_Id
;
20445 if Prag_Id
= Pragma_Max_Entry_Queue_Depth
20446 or else Prag_Id
= Pragma_Max_Queue_Length
20451 Check_Arg_Count
(1);
20454 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
20456 -- Entry declaration
20458 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
20460 -- Entry illegally within a task
20462 if Nkind
(Parent
(N
)) = N_Task_Definition
then
20463 Error_Pragma
("pragma % cannot apply to task entries");
20466 Entry_Id
:= Defining_Entity
(Entry_Decl
);
20468 -- Otherwise the pragma is associated with an illegal construct
20472 ("pragma % must apply to a protected entry declaration");
20475 -- Mark the pragma as Ghost if the related subprogram is also
20476 -- Ghost. This also ensures that any expansion performed further
20477 -- below will produce Ghost nodes.
20479 Mark_Ghost_Pragma
(N
, Entry_Id
);
20481 -- Analyze the Integer expression
20483 Arg
:= Get_Pragma_Arg
(Arg1
);
20484 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
20486 Val
:= Expr_Value
(Arg
);
20490 ("argument for pragma% cannot be less than -1", Arg1
);
20492 elsif not UI_Is_In_Int_Range
(Val
) then
20494 ("argument for pragma% out of range of Integer", Arg1
);
20498 Record_Rep_Item
(Entry_Id
, N
);
20499 end Max_Entry_Queue_Length
;
20505 -- pragma Memory_Size (NUMERIC_LITERAL)
20507 when Pragma_Memory_Size
=>
20510 -- Memory size is simply ignored
20512 Check_No_Identifiers
;
20513 Check_Arg_Count
(1);
20514 Check_Arg_Is_Integer_Literal
(Arg1
);
20522 -- The only correct use of this pragma is on its own in a file, in
20523 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
20524 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
20525 -- check for a file containing nothing but a No_Body pragma). If we
20526 -- attempt to process it during normal semantics processing, it means
20527 -- it was misplaced.
20529 when Pragma_No_Body
=>
20533 -----------------------------
20534 -- No_Elaboration_Code_All --
20535 -----------------------------
20537 -- pragma No_Elaboration_Code_All;
20539 when Pragma_No_Elaboration_Code_All
=>
20541 Check_Valid_Library_Unit_Pragma
;
20543 -- If N was rewritten as a null statement there is nothing more
20546 if Nkind
(N
) = N_Null_Statement
then
20550 -- Must appear for a spec or generic spec
20552 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) not in
20553 N_Generic_Package_Declaration |
20554 N_Generic_Subprogram_Declaration |
20555 N_Package_Declaration |
20556 N_Subprogram_Declaration
20560 ("pragma% can only occur for package "
20561 & "or subprogram spec"));
20564 -- Set flag in unit table
20566 Set_No_Elab_Code_All
(Current_Sem_Unit
);
20568 -- Set restriction No_Elaboration_Code if this is the main unit
20570 if Current_Sem_Unit
= Main_Unit
then
20571 Set_Restriction
(No_Elaboration_Code
, N
);
20574 -- If we are in the main unit or in an extended main source unit,
20575 -- then we also add it to the configuration restrictions so that
20576 -- it will apply to all units in the extended main source.
20578 if Current_Sem_Unit
= Main_Unit
20579 or else In_Extended_Main_Source_Unit
(N
)
20581 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
20584 -- If in main extended unit, activate transitive with test
20586 if In_Extended_Main_Source_Unit
(N
) then
20587 Opt
.No_Elab_Code_All_Pragma
:= N
;
20590 -----------------------------
20591 -- No_Component_Reordering --
20592 -----------------------------
20594 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
20596 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
20602 Check_At_Most_N_Arguments
(1);
20604 if Arg_Count
= 0 then
20605 Check_Valid_Configuration_Pragma
;
20606 Opt
.No_Component_Reordering
:= True;
20609 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20610 Check_Arg_Is_Local_Name
(Arg1
);
20611 E_Id
:= Get_Pragma_Arg
(Arg1
);
20613 if Etype
(E_Id
) = Any_Type
then
20617 E
:= Entity
(E_Id
);
20619 if not Is_Record_Type
(E
) then
20620 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
20623 Set_No_Reordering
(Base_Type
(E
));
20625 end No_Comp_Reordering
;
20627 --------------------------
20628 -- No_Heap_Finalization --
20629 --------------------------
20631 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
20633 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
20634 Context
: constant Node_Id
:= Parent
(N
);
20635 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20641 Check_No_Identifiers
;
20643 -- The pragma appears in a configuration file
20645 if No
(Context
) then
20646 Check_Arg_Count
(0);
20647 Check_Valid_Configuration_Pragma
;
20649 -- Detect a duplicate pragma
20651 if Present
(No_Heap_Finalization_Pragma
) then
20654 Prev
=> No_Heap_Finalization_Pragma
);
20658 No_Heap_Finalization_Pragma
:= N
;
20660 -- Otherwise the pragma should be associated with a library-level
20661 -- named access-to-object type.
20664 Check_Arg_Count
(1);
20665 Check_Arg_Is_Local_Name
(Arg1
);
20667 Find_Type
(Typ_Arg
);
20668 Typ
:= Entity
(Typ_Arg
);
20670 -- The type being subjected to the pragma is erroneous
20672 if Typ
= Any_Type
then
20673 Error_Pragma
("cannot find type referenced by pragma %");
20675 -- The pragma is applied to an incomplete or generic formal
20676 -- type way too early.
20678 elsif Rep_Item_Too_Early
(Typ
, N
) then
20682 Typ
:= Underlying_Type
(Typ
);
20685 -- The pragma must apply to an access-to-object type
20687 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
then
20690 -- Give a detailed error message on all other access type kinds
20692 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
20694 ("pragma % cannot apply to access protected subprogram "
20697 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
20699 ("pragma % cannot apply to access subprogram type");
20701 elsif Is_Anonymous_Access_Type
(Typ
) then
20703 ("pragma % cannot apply to anonymous access type");
20705 -- Give a general error message in case the pragma applies to a
20706 -- non-access type.
20710 ("pragma % must apply to library level access type");
20713 -- At this point the argument denotes an access-to-object type.
20714 -- Ensure that the type is declared at the library level.
20716 if Is_Library_Level_Entity
(Typ
) then
20719 -- Quietly ignore an access-to-object type originally declared
20720 -- at the library level within a generic, but instantiated at
20721 -- a non-library level. As a result the access-to-object type
20722 -- "loses" its No_Heap_Finalization property.
20724 elsif In_Instance
then
20729 ("pragma % must apply to library level access type");
20732 -- Detect a duplicate pragma
20734 if Present
(No_Heap_Finalization_Pragma
) then
20737 Prev
=> No_Heap_Finalization_Pragma
);
20741 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
20743 if Present
(Prev
) then
20751 Record_Rep_Item
(Typ
, N
);
20753 end No_Heap_Finalization
;
20759 -- pragma No_Inline ( NAME {, NAME} );
20761 when Pragma_No_Inline
=>
20763 Process_Inline
(Suppressed
);
20769 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20771 when Pragma_No_Return
=> Prag_No_Return
: declare
20773 function Check_No_Return
20775 N
: Node_Id
) return Boolean;
20776 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
20777 -- emit an error message and return False, otherwise return True.
20778 -- 6.5.1 Nonreturning procedures:
20779 -- 4/3 "Aspect No_Return shall not be specified for a null
20780 -- procedure nor an instance of a generic unit."
20782 ---------------------
20783 -- Check_No_Return --
20784 ---------------------
20786 function Check_No_Return
20788 N
: Node_Id
) return Boolean
20791 if Ekind
(E
) in E_Function | E_Generic_Function
then
20792 Error_Msg_Ada_2022_Feature
("No_Return function", Sloc
(N
));
20793 return Ada_Version
>= Ada_2022
;
20795 elsif Ekind
(E
) = E_Procedure
then
20797 -- If E is a generic instance, marking it with No_Return
20798 -- is forbidden, but having it inherit the No_Return of
20799 -- the generic is allowed. We check if E is inheriting its
20800 -- No_Return flag from the generic by checking if No_Return
20803 if Is_Generic_Instance
(E
) and then not No_Return
(E
) then
20805 ("generic instance & is marked as No_Return", N
, E
);
20807 ("\generic procedure & must be marked No_Return",
20809 Generic_Parent
(Parent
(E
)));
20812 elsif Null_Present
(Subprogram_Specification
(E
)) then
20814 ("null procedure & cannot be marked No_Return", N
, E
);
20820 end Check_No_Return
;
20827 Ghost_Error_Posted
: Boolean := False;
20828 -- Flag set when an error concerning the illegal mix of Ghost and
20829 -- non-Ghost subprograms is emitted.
20831 Ghost_Id
: Entity_Id
:= Empty
;
20832 -- The entity of the first Ghost procedure encountered while
20833 -- processing the arguments of the pragma.
20837 Check_At_Least_N_Arguments
(1);
20839 -- Loop through arguments of pragma
20842 while Present
(Arg
) loop
20843 Check_Arg_Is_Local_Name
(Arg
);
20844 Id
:= Get_Pragma_Arg
(Arg
);
20847 if not Is_Entity_Name
(Id
) then
20848 Error_Pragma_Arg
("entity name required", Arg
);
20851 if Etype
(Id
) = Any_Type
then
20855 -- Loop to find matching procedures or functions (Ada 2022)
20861 and then Scope
(E
) = Current_Scope
20863 -- Ada 2022 (AI12-0269): A function can be No_Return
20865 if Ekind
(E
) in E_Generic_Procedure | E_Procedure
20866 | E_Generic_Function | E_Function
20868 -- Check that the pragma is not applied to a body.
20869 -- First check the specless body case, to give a
20870 -- different error message. These checks do not apply
20871 -- if Relaxed_RM_Semantics, to accommodate other Ada
20872 -- compilers. Disable these checks under -gnatd.J.
20874 if not Debug_Flag_Dot_JJ
then
20875 if Nkind
(Parent
(Declaration_Node
(E
))) =
20877 and then not Relaxed_RM_Semantics
20880 ("pragma% requires separate spec and must come "
20884 -- Now the "specful" body case
20886 if Rep_Item_Too_Late
(E
, N
) then
20891 if Check_No_Return
(E
, N
) then
20895 -- A pragma that applies to a Ghost entity becomes Ghost
20896 -- for the purposes of legality checks and removal of
20897 -- ignored Ghost code.
20899 Mark_Ghost_Pragma
(N
, E
);
20901 -- Capture the entity of the first Ghost procedure being
20902 -- processed for error detection purposes.
20904 if Is_Ghost_Entity
(E
) then
20905 if No
(Ghost_Id
) then
20909 -- Otherwise the subprogram is non-Ghost. It is illegal
20910 -- to mix references to Ghost and non-Ghost entities
20913 elsif Present
(Ghost_Id
)
20914 and then not Ghost_Error_Posted
20916 Ghost_Error_Posted
:= True;
20918 Error_Msg_Name_1
:= Pname
;
20920 ("pragma % cannot mention ghost and non-ghost "
20921 & "procedures", N
);
20923 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
20924 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
20926 Error_Msg_Sloc
:= Sloc
(E
);
20927 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
20930 -- Set flag on any alias as well
20932 if Is_Overloadable
(E
)
20933 and then Present
(Alias
(E
))
20934 and then Check_No_Return
(Alias
(E
), N
)
20936 Set_No_Return
(Alias
(E
));
20942 exit when From_Aspect_Specification
(N
);
20946 -- If entity in not in current scope it may be the enclosing
20947 -- subprogram body to which the aspect applies.
20950 if Entity
(Id
) = Current_Scope
20951 and then From_Aspect_Specification
(N
)
20952 and then Check_No_Return
(Entity
(Id
), N
)
20954 Set_No_Return
(Entity
(Id
));
20956 elsif Ada_Version
>= Ada_2022
then
20958 ("no subprogram& found for pragma%", Arg
);
20961 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
20967 end Prag_No_Return
;
20973 -- pragma No_Run_Time;
20975 -- Note: this pragma is retained for backwards compatibility. See
20976 -- body of Rtsfind for full details on its handling.
20978 when Pragma_No_Run_Time
=>
20980 Check_Valid_Configuration_Pragma
;
20981 Check_Arg_Count
(0);
20983 -- Remove backward compatibility if Build_Type is FSF or GPL and
20984 -- generate a warning.
20987 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
20990 Error_Pragma
("pragma% is ignored, has no effect??");
20992 No_Run_Time_Mode
:= True;
20993 Configurable_Run_Time_Mode
:= True;
20995 -- Set Duration to 32 bits if word size is 32
20997 if Ttypes
.System_Word_Size
= 32 then
20998 Duration_32_Bits_On_Target
:= True;
21001 -- Set appropriate restrictions
21003 Set_Restriction
(No_Finalization
, N
);
21004 Set_Restriction
(No_Exception_Handlers
, N
);
21005 Set_Restriction
(Max_Tasks
, N
, 0);
21006 Set_Restriction
(No_Tasking
, N
);
21010 -----------------------
21011 -- No_Tagged_Streams --
21012 -----------------------
21014 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
21016 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
21022 Check_At_Most_N_Arguments
(1);
21024 -- One argument case
21026 if Arg_Count
= 1 then
21027 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21028 Check_Arg_Is_Local_Name
(Arg1
);
21029 E_Id
:= Get_Pragma_Arg
(Arg1
);
21031 if Etype
(E_Id
) = Any_Type
then
21035 E
:= Entity
(E_Id
);
21037 Check_Duplicate_Pragma
(E
);
21039 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
21041 ("argument for pragma% must be root tagged type", Arg1
);
21044 if Rep_Item_Too_Early
(E
, N
)
21046 Rep_Item_Too_Late
(E
, N
)
21050 Set_No_Tagged_Streams_Pragma
(E
, N
);
21053 -- Zero argument case
21056 Check_Is_In_Decl_Part_Or_Package_Spec
;
21057 No_Tagged_Streams
:= N
;
21059 end No_Tagged_Strms
;
21061 ------------------------
21062 -- No_Strict_Aliasing --
21063 ------------------------
21065 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
21067 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
21073 Check_At_Most_N_Arguments
(1);
21075 if Arg_Count
= 0 then
21076 Check_Valid_Configuration_Pragma
;
21077 Opt
.No_Strict_Aliasing
:= True;
21080 Check_Optional_Identifier
(Arg2
, Name_Entity
);
21081 Check_Arg_Is_Local_Name
(Arg1
);
21082 E_Id
:= Get_Pragma_Arg
(Arg1
);
21084 if Etype
(E_Id
) = Any_Type
then
21088 E
:= Entity
(E_Id
);
21090 if not Is_Access_Type
(E
) then
21091 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
21094 Set_No_Strict_Aliasing
(Base_Type
(E
));
21096 end No_Strict_Aliasing
;
21098 -----------------------
21099 -- Normalize_Scalars --
21100 -----------------------
21102 -- pragma Normalize_Scalars;
21104 when Pragma_Normalize_Scalars
=>
21105 Check_Ada_83_Warning
;
21106 Check_Arg_Count
(0);
21107 Check_Valid_Configuration_Pragma
;
21109 -- Normalize_Scalars creates false positives in CodePeer, and
21110 -- incorrect negative results in GNATprove mode, so ignore this
21111 -- pragma in these modes.
21113 if not (CodePeer_Mode
or GNATprove_Mode
) then
21114 Normalize_Scalars
:= True;
21115 Init_Or_Norm_Scalars
:= True;
21122 -- pragma Obsolescent;
21124 -- pragma Obsolescent (
21125 -- [Message =>] static_string_EXPRESSION
21126 -- [,[Version =>] Ada_05]);
21128 -- pragma Obsolescent (
21129 -- [Entity =>] NAME
21130 -- [,[Message =>] static_string_EXPRESSION
21131 -- [,[Version =>] Ada_05]]);
21133 when Pragma_Obsolescent
=> Obsolescent
: declare
21137 procedure Set_Obsolescent
(E
: Entity_Id
);
21138 -- Given an entity Ent, mark it as obsolescent if appropriate
21140 ---------------------
21141 -- Set_Obsolescent --
21142 ---------------------
21144 procedure Set_Obsolescent
(E
: Entity_Id
) is
21153 -- A pragma that applies to a Ghost entity becomes Ghost for
21154 -- the purposes of legality checks and removal of ignored Ghost
21157 Mark_Ghost_Pragma
(N
, E
);
21159 -- Entity name was given
21161 if Present
(Ename
) then
21163 -- If entity name matches, we are fine.
21165 if Chars
(Ename
) = Chars
(Ent
) then
21166 Set_Entity
(Ename
, Ent
);
21167 Generate_Reference
(Ent
, Ename
);
21169 -- If entity name does not match, only possibility is an
21170 -- enumeration literal from an enumeration type declaration.
21172 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
21174 ("pragma % entity name does not match declaration");
21177 Ent
:= First_Literal
(E
);
21181 ("pragma % entity name does not match any "
21182 & "enumeration literal");
21184 elsif Chars
(Ent
) = Chars
(Ename
) then
21185 Set_Entity
(Ename
, Ent
);
21186 Generate_Reference
(Ent
, Ename
);
21190 Next_Literal
(Ent
);
21196 -- Ent points to entity to be marked
21198 if Arg_Count
>= 1 then
21200 -- Deal with static string argument
21202 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21203 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
21205 for J
in 1 .. String_Length
(S
) loop
21206 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
21208 ("pragma% argument does not allow wide characters",
21213 Obsolescent_Warnings
.Append
21214 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
21216 -- Check for Ada_05 parameter
21218 if Arg_Count
/= 1 then
21219 Check_Arg_Count
(2);
21222 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21225 Check_Arg_Is_Identifier
(Argx
);
21227 if Chars
(Argx
) /= Name_Ada_05
then
21228 Error_Msg_Name_2
:= Name_Ada_05
;
21230 ("only allowed argument for pragma% is %", Argx
);
21233 if Ada_Version_Explicit
< Ada_2005
21234 or else not Warn_On_Ada_2005_Compatibility
21242 -- Set flag if pragma active
21245 Set_Is_Obsolescent
(Ent
);
21249 end Set_Obsolescent
;
21251 -- Start of processing for pragma Obsolescent
21256 Check_At_Most_N_Arguments
(3);
21258 -- See if first argument specifies an entity name
21262 (Chars
(Arg1
) = Name_Entity
21264 Nkind
(Get_Pragma_Arg
(Arg1
)) in
21265 N_Character_Literal | N_Identifier | N_Operator_Symbol
)
21267 Ename
:= Get_Pragma_Arg
(Arg1
);
21269 -- Eliminate first argument, so we can share processing
21273 Arg_Count
:= Arg_Count
- 1;
21275 -- No Entity name argument given
21281 if Arg_Count
>= 1 then
21282 Check_Optional_Identifier
(Arg1
, Name_Message
);
21284 if Arg_Count
= 2 then
21285 Check_Optional_Identifier
(Arg2
, Name_Version
);
21289 -- Get immediately preceding declaration
21292 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
21296 -- Cases where we do not follow anything other than another pragma
21300 -- Case 0: library level compilation unit declaration with
21301 -- the pragma preceding the declaration.
21303 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
21306 -- Case 1: library level compilation unit declaration with
21307 -- the pragma immediately following the declaration.
21309 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
21311 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
21314 -- Case 2: library unit placement for package
21318 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
21320 if Is_Package_Or_Generic_Package
(Ent
) then
21321 Set_Obsolescent
(Ent
);
21327 -- Cases where we must follow a declaration, including an
21328 -- abstract subprogram declaration, which is not in the
21329 -- other node subtypes.
21332 if Nkind
(Decl
) not in N_Declaration
21333 and then Nkind
(Decl
) not in N_Later_Decl_Item
21334 and then Nkind
(Decl
) not in N_Generic_Declaration
21335 and then Nkind
(Decl
) not in N_Renaming_Declaration
21336 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
21339 ("pragma% misplaced, "
21340 & "must immediately follow a declaration");
21343 Set_Obsolescent
(Defining_Entity
(Decl
));
21353 -- pragma Optimize (Time | Space | Off);
21355 -- The actual check for optimize is done in Gigi. Note that this
21356 -- pragma does not actually change the optimization setting, it
21357 -- simply checks that it is consistent with the pragma.
21359 when Pragma_Optimize
=>
21360 Check_No_Identifiers
;
21361 Check_Arg_Count
(1);
21362 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
21364 ------------------------
21365 -- Optimize_Alignment --
21366 ------------------------
21368 -- pragma Optimize_Alignment (Time | Space | Off);
21370 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
21372 Check_No_Identifiers
;
21373 Check_Arg_Count
(1);
21374 Check_Valid_Configuration_Pragma
;
21377 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
21380 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
21381 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
21382 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
21385 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
21389 -- Set indication that mode is set locally. If we are in fact in a
21390 -- configuration pragma file, this setting is harmless since the
21391 -- switch will get reset anyway at the start of each unit.
21393 Optimize_Alignment_Local
:= True;
21394 end Optimize_Alignment
;
21400 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
21402 when Pragma_Ordered
=> Ordered
: declare
21403 Assoc
: constant Node_Id
:= Arg1
;
21409 Check_No_Identifiers
;
21410 Check_Arg_Count
(1);
21411 Check_Arg_Is_Local_Name
(Arg1
);
21413 Type_Id
:= Get_Pragma_Arg
(Assoc
);
21414 Find_Type
(Type_Id
);
21415 Typ
:= Entity
(Type_Id
);
21417 if Typ
= Any_Type
then
21420 Typ
:= Underlying_Type
(Typ
);
21423 if not Is_Enumeration_Type
(Typ
) then
21424 Error_Pragma
("pragma% must specify enumeration type");
21427 Check_First_Subtype
(Arg1
);
21428 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
21431 -------------------
21432 -- Overflow_Mode --
21433 -------------------
21435 -- pragma Overflow_Mode
21436 -- ([General => ] MODE [, [Assertions => ] MODE]);
21438 -- MODE := STRICT | MINIMIZED | ELIMINATED
21440 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
21441 -- since System.Bignums makes this assumption. This is true of nearly
21442 -- all (all?) targets.
21444 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
21445 function Get_Overflow_Mode
21447 Arg
: Node_Id
) return Overflow_Mode_Type
;
21448 -- Function to process one pragma argument, Arg. If an identifier
21449 -- is present, it must be Name. Mode type is returned if a valid
21450 -- argument exists, otherwise an error is signalled.
21452 -----------------------
21453 -- Get_Overflow_Mode --
21454 -----------------------
21456 function Get_Overflow_Mode
21458 Arg
: Node_Id
) return Overflow_Mode_Type
21460 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
21463 Check_Optional_Identifier
(Arg
, Name
);
21464 Check_Arg_Is_Identifier
(Argx
);
21466 if Chars
(Argx
) = Name_Strict
then
21469 elsif Chars
(Argx
) = Name_Minimized
then
21472 elsif Chars
(Argx
) = Name_Eliminated
then
21473 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
21475 ("Eliminated requires Long_Long_Integer'Size = 64",
21482 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
21484 end Get_Overflow_Mode
;
21486 -- Start of processing for Overflow_Mode
21490 Check_At_Least_N_Arguments
(1);
21491 Check_At_Most_N_Arguments
(2);
21493 -- Process first argument
21495 Scope_Suppress
.Overflow_Mode_General
:=
21496 Get_Overflow_Mode
(Name_General
, Arg1
);
21498 -- Case of only one argument
21500 if Arg_Count
= 1 then
21501 Scope_Suppress
.Overflow_Mode_Assertions
:=
21502 Scope_Suppress
.Overflow_Mode_General
;
21504 -- Case of two arguments present
21507 Scope_Suppress
.Overflow_Mode_Assertions
:=
21508 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
21512 --------------------------
21513 -- Overriding Renamings --
21514 --------------------------
21516 -- pragma Overriding_Renamings;
21518 when Pragma_Overriding_Renamings
=>
21520 Check_Arg_Count
(0);
21521 Check_Valid_Configuration_Pragma
;
21522 Overriding_Renamings
:= True;
21528 -- pragma Pack (first_subtype_LOCAL_NAME);
21530 when Pragma_Pack
=> Pack
: declare
21531 Assoc
: constant Node_Id
:= Arg1
;
21533 Ignore
: Boolean := False;
21538 Check_No_Identifiers
;
21539 Check_Arg_Count
(1);
21540 Check_Arg_Is_Local_Name
(Arg1
);
21541 Type_Id
:= Get_Pragma_Arg
(Assoc
);
21543 if not Is_Entity_Name
(Type_Id
)
21544 or else not Is_Type
(Entity
(Type_Id
))
21547 ("argument for pragma% must be type or subtype", Arg1
);
21550 Find_Type
(Type_Id
);
21551 Typ
:= Entity
(Type_Id
);
21554 or else Rep_Item_Too_Early
(Typ
, N
)
21558 Typ
:= Underlying_Type
(Typ
);
21561 -- A pragma that applies to a Ghost entity becomes Ghost for the
21562 -- purposes of legality checks and removal of ignored Ghost code.
21564 Mark_Ghost_Pragma
(N
, Typ
);
21566 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
21567 Error_Pragma
("pragma% must specify array or record type");
21570 Check_First_Subtype
(Arg1
);
21571 Check_Duplicate_Pragma
(Typ
);
21575 if Is_Array_Type
(Typ
) then
21576 Ctyp
:= Component_Type
(Typ
);
21578 -- Ignore pack that does nothing
21580 if Known_Static_Esize
(Ctyp
)
21581 and then Known_Static_RM_Size
(Ctyp
)
21582 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
21583 and then Addressable
(Esize
(Ctyp
))
21588 -- Process OK pragma Pack. Note that if there is a separate
21589 -- component clause present, the Pack will be cancelled. This
21590 -- processing is in Freeze.
21592 if not Rep_Item_Too_Late
(Typ
, N
) then
21594 -- In CodePeer mode, we do not need complex front-end
21595 -- expansions related to pragma Pack, so disable handling
21598 if CodePeer_Mode
then
21601 -- Normal case where we do the pack action
21605 Set_Is_Packed
(Base_Type
(Typ
));
21606 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
21609 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
21613 -- For record types, the pack is always effective
21615 else pragma Assert
(Is_Record_Type
(Typ
));
21616 if not Rep_Item_Too_Late
(Typ
, N
) then
21617 Set_Is_Packed
(Base_Type
(Typ
));
21618 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
21619 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
21630 -- There is nothing to do here, since we did all the processing for
21631 -- this pragma in Par.Prag (so that it works properly even in syntax
21634 when Pragma_Page
=>
21641 -- pragma Part_Of (ABSTRACT_STATE);
21643 -- ABSTRACT_STATE ::= NAME
21645 when Pragma_Part_Of
=> Part_Of
: declare
21646 procedure Propagate_Part_Of
21647 (Pack_Id
: Entity_Id
;
21648 State_Id
: Entity_Id
;
21649 Instance
: Node_Id
);
21650 -- Propagate the Part_Of indicator to all abstract states and
21651 -- objects declared in the visible state space of a package
21652 -- denoted by Pack_Id. State_Id is the encapsulating state.
21653 -- Instance is the package instantiation node.
21655 -----------------------
21656 -- Propagate_Part_Of --
21657 -----------------------
21659 procedure Propagate_Part_Of
21660 (Pack_Id
: Entity_Id
;
21661 State_Id
: Entity_Id
;
21662 Instance
: Node_Id
)
21664 Has_Item
: Boolean := False;
21665 -- Flag set when the visible state space contains at least one
21666 -- abstract state or variable.
21668 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
21669 -- Propagate the Part_Of indicator to all abstract states and
21670 -- objects declared in the visible state space of a package
21671 -- denoted by Pack_Id.
21673 -----------------------
21674 -- Propagate_Part_Of --
21675 -----------------------
21677 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
21678 Constits
: Elist_Id
;
21679 Item_Id
: Entity_Id
;
21682 -- Traverse the entity chain of the package and set relevant
21683 -- attributes of abstract states and objects declared in the
21684 -- visible state space of the package.
21686 Item_Id
:= First_Entity
(Pack_Id
);
21687 while Present
(Item_Id
)
21688 and then not In_Private_Part
(Item_Id
)
21690 -- Do not consider internally generated items
21692 if not Comes_From_Source
(Item_Id
) then
21695 -- Do not consider generic formals or their corresponding
21696 -- actuals because they are not part of a visible state.
21697 -- Note that both entities are marked as hidden.
21699 elsif Is_Hidden
(Item_Id
) then
21702 -- The Part_Of indicator turns an abstract state or an
21703 -- object into a constituent of the encapsulating state.
21704 -- Note that constants are considered here even though
21705 -- they may not depend on variable input. This check is
21706 -- left to the SPARK prover.
21708 elsif Ekind
(Item_Id
) in
21709 E_Abstract_State | E_Constant | E_Variable
21712 Constits
:= Part_Of_Constituents
(State_Id
);
21714 if No
(Constits
) then
21715 Constits
:= New_Elmt_List
;
21716 Set_Part_Of_Constituents
(State_Id
, Constits
);
21719 Append_Elmt
(Item_Id
, Constits
);
21720 Set_Encapsulating_State
(Item_Id
, State_Id
);
21722 -- Recursively handle nested packages and instantiations
21724 elsif Ekind
(Item_Id
) = E_Package
then
21725 Propagate_Part_Of
(Item_Id
);
21728 Next_Entity
(Item_Id
);
21730 end Propagate_Part_Of
;
21732 -- Start of processing for Propagate_Part_Of
21735 Propagate_Part_Of
(Pack_Id
);
21737 -- Detect a package instantiation that is subject to a Part_Of
21738 -- indicator, but has no visible state.
21740 if not Has_Item
then
21742 ("package instantiation & has Part_Of indicator but "
21743 & "lacks visible state", Instance
, Pack_Id
);
21745 end Propagate_Part_Of
;
21749 Constits
: Elist_Id
;
21751 Encap_Id
: Entity_Id
;
21752 Item_Id
: Entity_Id
;
21756 -- Start of processing for Part_Of
21760 Check_No_Identifiers
;
21761 Check_Arg_Count
(1);
21763 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
21765 -- Object declaration
21767 if Nkind
(Stmt
) = N_Object_Declaration
then
21770 -- Package instantiation
21772 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
21775 -- Single concurrent type declaration
21777 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
21780 -- Otherwise the pragma is associated with an illegal construct
21786 -- Extract the entity of the related object declaration or package
21787 -- instantiation. In the case of the instantiation, use the entity
21788 -- of the instance spec.
21790 if Nkind
(Stmt
) = N_Package_Instantiation
then
21791 Stmt
:= Instance_Spec
(Stmt
);
21794 Item_Id
:= Defining_Entity
(Stmt
);
21796 -- A pragma that applies to a Ghost entity becomes Ghost for the
21797 -- purposes of legality checks and removal of ignored Ghost code.
21799 Mark_Ghost_Pragma
(N
, Item_Id
);
21801 -- Chain the pragma on the contract for further processing by
21802 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21804 Add_Contract_Item
(N
, Item_Id
);
21806 -- A variable may act as constituent of a single concurrent type
21807 -- which in turn could be declared after the variable. Due to this
21808 -- discrepancy, the full analysis of indicator Part_Of is delayed
21809 -- until the end of the enclosing declarative region (see routine
21810 -- Analyze_Part_Of_In_Decl_Part).
21812 if Ekind
(Item_Id
) = E_Variable
then
21815 -- Otherwise indicator Part_Of applies to a constant or a package
21819 Encap
:= Get_Pragma_Arg
(Arg1
);
21821 -- Detect any discrepancies between the placement of the
21822 -- constant or package instantiation with respect to state
21823 -- space and the encapsulating state.
21827 Item_Id
=> Item_Id
,
21829 Encap_Id
=> Encap_Id
,
21833 pragma Assert
(Present
(Encap_Id
));
21835 if Ekind
(Item_Id
) = E_Constant
then
21836 Constits
:= Part_Of_Constituents
(Encap_Id
);
21838 if No
(Constits
) then
21839 Constits
:= New_Elmt_List
;
21840 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
21843 Append_Elmt
(Item_Id
, Constits
);
21844 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
21846 -- Propagate the Part_Of indicator to the visible state
21847 -- space of the package instantiation.
21851 (Pack_Id
=> Item_Id
,
21852 State_Id
=> Encap_Id
,
21859 ----------------------------------
21860 -- Partition_Elaboration_Policy --
21861 ----------------------------------
21863 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21865 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
21866 subtype PEP_Range
is Name_Id
21867 range First_Partition_Elaboration_Policy_Name
21868 .. Last_Partition_Elaboration_Policy_Name
;
21869 PEP_Val
: PEP_Range
;
21874 Check_Arg_Count
(1);
21875 Check_No_Identifiers
;
21876 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
21877 Check_Valid_Configuration_Pragma
;
21878 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
21881 when Name_Concurrent
=> PEP
:= 'C';
21882 when Name_Sequential
=> PEP
:= 'S';
21885 if Partition_Elaboration_Policy
/= ' '
21886 and then Partition_Elaboration_Policy
/= PEP
21888 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
21890 ("partition elaboration policy incompatible with policy#");
21892 -- Set new policy, but always preserve System_Location since we
21893 -- like the error message with the run time name.
21896 Partition_Elaboration_Policy
:= PEP
;
21898 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
21899 Partition_Elaboration_Policy_Sloc
:= Loc
;
21902 if PEP_Val
= Name_Sequential
21903 and then not Restriction_Active
(No_Task_Hierarchy
)
21905 -- RM H.6(6) guarantees that No_Task_Hierarchy will be
21906 -- set eventually, so take advantage of that knowledge now.
21907 -- But we have to do this in a tricky way. If we simply
21908 -- set the No_Task_Hierarchy restriction here, then the
21909 -- assumption that the restriction will be set eventually
21910 -- becomes a self-fulfilling prophecy; the binder can
21911 -- then mistakenly conclude that the H.6(6) rule is
21912 -- satisified in cases where the post-compilation check
21913 -- should fail. So we invent a new restriction,
21914 -- No_Task_Hierarchy_Implicit, which is treated specially
21915 -- in the function Restriction_Active.
21917 Set_Restriction
(No_Task_Hierarchy_Implicit
, N
);
21918 pragma Assert
(Restriction_Active
(No_Task_Hierarchy
));
21927 -- pragma Passive [(PASSIVE_FORM)];
21929 -- PASSIVE_FORM ::= Semaphore | No
21931 when Pragma_Passive
=>
21934 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
21935 Error_Pragma
("pragma% must be within task definition");
21938 if Arg_Count
/= 0 then
21939 Check_Arg_Count
(1);
21940 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
21943 ----------------------------------
21944 -- Preelaborable_Initialization --
21945 ----------------------------------
21947 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21949 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
21954 Check_Arg_Count
(1);
21955 Check_No_Identifiers
;
21956 Check_Arg_Is_Identifier
(Arg1
);
21957 Check_Arg_Is_Local_Name
(Arg1
);
21958 Check_First_Subtype
(Arg1
);
21959 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21961 -- A pragma that applies to a Ghost entity becomes Ghost for the
21962 -- purposes of legality checks and removal of ignored Ghost code.
21964 Mark_Ghost_Pragma
(N
, Ent
);
21966 -- The pragma may come from an aspect on a private declaration,
21967 -- even if the freeze point at which this is analyzed in the
21968 -- private part after the full view.
21970 if Has_Private_Declaration
(Ent
)
21971 and then From_Aspect_Specification
(N
)
21975 -- Check appropriate type argument
21977 elsif Is_Private_Type
(Ent
)
21978 or else Is_Protected_Type
(Ent
)
21979 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
21981 -- AI05-0028: The pragma applies to all composite types. Note
21982 -- that we apply this binding interpretation to earlier versions
21983 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21984 -- choice since there are other compilers that do the same.
21986 or else Is_Composite_Type
(Ent
)
21992 ("pragma % can only be applied to private, formal derived, "
21993 & "protected, or composite type", Arg1
);
21996 -- Give an error if the pragma is applied to a protected type that
21997 -- does not qualify (due to having entries, or due to components
21998 -- that do not qualify).
22000 if Is_Protected_Type
(Ent
)
22001 and then not Has_Preelaborable_Initialization
(Ent
)
22004 ("protected type & does not have preelaborable "
22005 & "initialization", Ent
);
22007 -- Otherwise mark the type as definitely having preelaborable
22011 Set_Known_To_Have_Preelab_Init
(Ent
);
22014 if Has_Pragma_Preelab_Init
(Ent
)
22015 and then Warn_On_Redundant_Constructs
22017 Error_Pragma
("?r?duplicate pragma%!");
22019 Set_Has_Pragma_Preelab_Init
(Ent
);
22023 --------------------
22024 -- Persistent_BSS --
22025 --------------------
22027 -- pragma Persistent_BSS [(object_NAME)];
22029 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
22036 Check_At_Most_N_Arguments
(1);
22038 -- Case of application to specific object (one argument)
22040 if Arg_Count
= 1 then
22041 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22043 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
22045 Ekind
(Entity
(Get_Pragma_Arg
(Arg1
))) not in
22046 E_Variable | E_Constant
22048 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
22051 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
22053 -- A pragma that applies to a Ghost entity becomes Ghost for
22054 -- the purposes of legality checks and removal of ignored Ghost
22057 Mark_Ghost_Pragma
(N
, Ent
);
22059 -- Check for duplication before inserting in list of
22060 -- representation items.
22062 Check_Duplicate_Pragma
(Ent
);
22064 if Rep_Item_Too_Late
(Ent
, N
) then
22068 Decl
:= Parent
(Ent
);
22070 if Present
(Expression
(Decl
)) then
22071 -- Variables in Persistent_BSS cannot be initialized, so
22072 -- turn off any initialization that might be caused by
22073 -- pragmas Initialize_Scalars or Normalize_Scalars.
22075 if Kill_Range_Check
(Expression
(Decl
)) then
22078 Name_Suppress_Initialization
,
22079 Pragma_Argument_Associations
=> New_List
(
22080 Make_Pragma_Argument_Association
(Loc
,
22081 Expression
=> New_Occurrence_Of
(Ent
, Loc
))));
22082 Insert_Before
(N
, Prag
);
22087 ("object for pragma% cannot have initialization", Arg1
);
22091 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
22093 ("object type for pragma% is not potentially persistent",
22098 Make_Linker_Section_Pragma
22099 (Ent
, Loc
, ".persistent.bss");
22100 Insert_After
(N
, Prag
);
22103 -- Case of use as configuration pragma with no arguments
22106 Check_Valid_Configuration_Pragma
;
22107 Persistent_BSS_Mode
:= True;
22109 end Persistent_BSS
;
22111 --------------------
22112 -- Rename_Pragma --
22113 --------------------
22115 -- pragma Rename_Pragma (
22116 -- [New_Name =>] IDENTIFIER,
22117 -- [Renamed =>] pragma_IDENTIFIER);
22119 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
22120 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22121 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
22125 Check_Valid_Configuration_Pragma
;
22126 Check_Arg_Count
(2);
22127 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
22128 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
22130 if Nkind
(New_Name
) /= N_Identifier
then
22131 Error_Pragma_Arg
("identifier expected", Arg1
);
22134 if Nkind
(Old_Name
) /= N_Identifier
then
22135 Error_Pragma_Arg
("identifier expected", Arg2
);
22138 -- The New_Name arg should not be an existing pragma (but we allow
22139 -- it; it's just a warning). The Old_Name arg must be an existing
22142 if Is_Pragma_Name
(Chars
(New_Name
)) then
22143 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
22146 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
22147 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
22150 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
22153 -----------------------------------
22154 -- Post/Post_Class/Postcondition --
22155 -----------------------------------
22157 -- pragma Post (Boolean_EXPRESSION);
22158 -- pragma Post_Class (Boolean_EXPRESSION);
22159 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
22160 -- [,[Message =>] String_EXPRESSION]);
22162 -- Characteristics:
22164 -- * Analysis - The annotation undergoes initial checks to verify
22165 -- the legal placement and context. Secondary checks preanalyze the
22168 -- Analyze_Pre_Post_Condition_In_Decl_Part
22170 -- * Expansion - The annotation is expanded during the expansion of
22171 -- the related subprogram [body] contract as performed in:
22173 -- Expand_Subprogram_Contract
22175 -- * Template - The annotation utilizes the generic template of the
22176 -- related subprogram [body] when it is:
22178 -- aspect on subprogram declaration
22179 -- aspect on stand-alone subprogram body
22180 -- pragma on stand-alone subprogram body
22182 -- The annotation must prepare its own template when it is:
22184 -- pragma on subprogram declaration
22186 -- * Globals - Capture of global references must occur after full
22189 -- * Instance - The annotation is instantiated automatically when
22190 -- the related generic subprogram [body] is instantiated except for
22191 -- the "pragma on subprogram declaration" case. In that scenario
22192 -- the annotation must instantiate itself.
22195 | Pragma_Post_Class
22196 | Pragma_Postcondition
22198 Analyze_Pre_Post_Condition
;
22200 --------------------------------
22201 -- Pre/Pre_Class/Precondition --
22202 --------------------------------
22204 -- pragma Pre (Boolean_EXPRESSION);
22205 -- pragma Pre_Class (Boolean_EXPRESSION);
22206 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
22207 -- [,[Message =>] String_EXPRESSION]);
22209 -- Characteristics:
22211 -- * Analysis - The annotation undergoes initial checks to verify
22212 -- the legal placement and context. Secondary checks preanalyze the
22215 -- Analyze_Pre_Post_Condition_In_Decl_Part
22217 -- * Expansion - The annotation is expanded during the expansion of
22218 -- the related subprogram [body] contract as performed in:
22220 -- Expand_Subprogram_Contract
22222 -- * Template - The annotation utilizes the generic template of the
22223 -- related subprogram [body] when it is:
22225 -- aspect on subprogram declaration
22226 -- aspect on stand-alone subprogram body
22227 -- pragma on stand-alone subprogram body
22229 -- The annotation must prepare its own template when it is:
22231 -- pragma on subprogram declaration
22233 -- * Globals - Capture of global references must occur after full
22236 -- * Instance - The annotation is instantiated automatically when
22237 -- the related generic subprogram [body] is instantiated except for
22238 -- the "pragma on subprogram declaration" case. In that scenario
22239 -- the annotation must instantiate itself.
22243 | Pragma_Precondition
22245 Analyze_Pre_Post_Condition
;
22251 -- pragma Predicate
22252 -- ([Entity =>] type_LOCAL_NAME,
22253 -- [Check =>] boolean_EXPRESSION);
22255 when Pragma_Predicate
=> Predicate
: declare
22262 Check_Arg_Count
(2);
22263 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22264 Check_Optional_Identifier
(Arg2
, Name_Check
);
22266 Check_Arg_Is_Local_Name
(Arg1
);
22268 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22269 Find_Type
(Type_Id
);
22270 Typ
:= Entity
(Type_Id
);
22272 if Typ
= Any_Type
then
22276 -- A Ghost_Predicate aspect is always Ghost with a mode inherited
22277 -- from the context. A Predicate pragma that applies to a Ghost
22278 -- entity becomes Ghost for the purposes of legality checks and
22279 -- removal of ignored Ghost code.
22281 if From_Aspect_Specification
(N
)
22282 and then Get_Aspect_Id
22283 (Chars
(Identifier
(Corresponding_Aspect
(N
))))
22284 = Aspect_Ghost_Predicate
22287 (N
, Name_To_Ghost_Mode
(Policy_In_Effect
(Name_Ghost
)));
22289 Mark_Ghost_Pragma
(N
, Typ
);
22292 -- The remaining processing is simply to link the pragma on to
22293 -- the rep item chain, for processing when the type is frozen.
22294 -- This is accomplished by a call to Rep_Item_Too_Late. We also
22295 -- mark the type as having predicates.
22297 -- If the current policy for predicate checking is Ignore mark the
22298 -- subtype accordingly. In the case of predicates we consider them
22299 -- enabled unless Ignore is specified (either directly or with a
22300 -- general Assertion_Policy pragma) to preserve existing warnings.
22302 Set_Has_Predicates
(Typ
);
22304 -- Indicate that the pragma must be processed at the point the
22305 -- type is frozen, as is done for the corresponding aspect.
22307 Set_Has_Delayed_Aspects
(Typ
);
22308 Set_Has_Delayed_Freeze
(Typ
);
22310 Set_Predicates_Ignored
(Typ
,
22311 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
22312 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
22315 -----------------------
22316 -- Predicate_Failure --
22317 -----------------------
22319 -- pragma Predicate_Failure
22320 -- ([Entity =>] type_LOCAL_NAME,
22321 -- [Message =>] string_EXPRESSION);
22323 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
22330 Check_Arg_Count
(2);
22331 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22332 Check_Optional_Identifier
(Arg2
, Name_Message
);
22334 Check_Arg_Is_Local_Name
(Arg1
);
22336 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22337 Find_Type
(Type_Id
);
22338 Typ
:= Entity
(Type_Id
);
22340 if Typ
= Any_Type
then
22344 -- A pragma that applies to a Ghost entity becomes Ghost for the
22345 -- purposes of legality checks and removal of ignored Ghost code.
22347 Mark_Ghost_Pragma
(N
, Typ
);
22349 -- The remaining processing is simply to link the pragma on to
22350 -- the rep item chain, for processing when the type is frozen.
22351 -- This is accomplished by a call to Rep_Item_Too_Late.
22353 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
22354 end Predicate_Failure
;
22360 -- pragma Preelaborate [(library_unit_NAME)];
22362 -- Set the flag Is_Preelaborated of program unit name entity
22364 when Pragma_Preelaborate
=> Preelaborate
: declare
22365 Pa
: constant Node_Id
:= Parent
(N
);
22366 Pk
: constant Node_Kind
:= Nkind
(Pa
);
22370 Check_Ada_83_Warning
;
22371 Check_Valid_Library_Unit_Pragma
;
22373 -- If N was rewritten as a null statement there is nothing more
22376 if Nkind
(N
) = N_Null_Statement
then
22380 Ent
:= Find_Lib_Unit_Name
;
22382 -- A pragma that applies to a Ghost entity becomes Ghost for the
22383 -- purposes of legality checks and removal of ignored Ghost code.
22385 Mark_Ghost_Pragma
(N
, Ent
);
22386 Check_Duplicate_Pragma
(Ent
);
22388 -- This filters out pragmas inside generic parents that show up
22389 -- inside instantiations. Pragmas that come from aspects in the
22390 -- unit are not ignored.
22392 if Present
(Ent
) then
22393 if Pk
= N_Package_Specification
22394 and then Present
(Generic_Parent
(Pa
))
22395 and then not From_Aspect_Specification
(N
)
22400 if not Debug_Flag_U
then
22401 Set_Is_Preelaborated
(Ent
);
22403 if Legacy_Elaboration_Checks
then
22404 Set_Suppress_Elaboration_Warnings
(Ent
);
22411 -------------------------------
22412 -- Prefix_Exception_Messages --
22413 -------------------------------
22415 -- pragma Prefix_Exception_Messages;
22417 when Pragma_Prefix_Exception_Messages
=>
22419 Check_Valid_Configuration_Pragma
;
22420 Check_Arg_Count
(0);
22421 Prefix_Exception_Messages
:= True;
22427 -- pragma Priority (EXPRESSION);
22429 when Pragma_Priority
=> Priority
: declare
22430 P
: constant Node_Id
:= Parent
(N
);
22435 Check_No_Identifiers
;
22436 Check_Arg_Count
(1);
22440 if Nkind
(P
) = N_Subprogram_Body
then
22441 Check_In_Main_Program
;
22443 Ent
:= Defining_Unit_Name
(Specification
(P
));
22445 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
22446 Ent
:= Defining_Identifier
(Ent
);
22449 Arg
:= Get_Pragma_Arg
(Arg1
);
22450 Analyze_And_Resolve
(Arg
, Standard_Integer
);
22454 if not Is_OK_Static_Expression
(Arg
) then
22455 Flag_Non_Static_Expr
22456 ("main subprogram priority is not static!", Arg
);
22459 -- If constraint error, then we already signalled an error
22461 elsif Raises_Constraint_Error
(Arg
) then
22464 -- Otherwise check in range except if Relaxed_RM_Semantics
22465 -- where we ignore the value if out of range.
22468 if not Relaxed_RM_Semantics
22469 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
22472 ("main subprogram priority is out of range", Arg1
);
22475 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
22479 -- Load an arbitrary entity from System.Tasking.Stages or
22480 -- System.Tasking.Restricted.Stages (depending on the
22481 -- supported profile) to make sure that one of these packages
22482 -- is implicitly with'ed, since we need to have the tasking
22483 -- run time active for the pragma Priority to have any effect.
22484 -- Previously we with'ed the package System.Tasking, but this
22485 -- package does not trigger the required initialization of the
22486 -- run-time library.
22488 if Restricted_Profile
then
22489 Discard_Node
(RTE
(RE_Activate_Restricted_Tasks
));
22491 Discard_Node
(RTE
(RE_Activate_Tasks
));
22494 -- Task or Protected, must be of type Integer
22496 elsif Nkind
(P
) in N_Protected_Definition | N_Task_Definition
then
22497 Arg
:= Get_Pragma_Arg
(Arg1
);
22498 Ent
:= Defining_Identifier
(Parent
(P
));
22500 -- The expression must be analyzed in the special manner
22501 -- described in "Handling of Default and Per-Object
22502 -- Expressions" in sem.ads.
22504 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
22506 if not Is_OK_Static_Expression
(Arg
) then
22507 Check_Restriction
(Static_Priorities
, Arg
);
22510 -- Anything else is incorrect
22516 -- Check duplicate pragma before we chain the pragma in the Rep
22517 -- Item chain of Ent.
22519 Check_Duplicate_Pragma
(Ent
);
22520 Record_Rep_Item
(Ent
, N
);
22523 -----------------------------------
22524 -- Priority_Specific_Dispatching --
22525 -----------------------------------
22527 -- pragma Priority_Specific_Dispatching (
22528 -- policy_IDENTIFIER,
22529 -- first_priority_EXPRESSION,
22530 -- last_priority_EXPRESSION);
22532 when Pragma_Priority_Specific_Dispatching
=>
22533 Priority_Specific_Dispatching
: declare
22534 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
22535 -- This is the entity System.Any_Priority;
22538 Lower_Bound
: Node_Id
;
22539 Upper_Bound
: Node_Id
;
22545 Check_Arg_Count
(3);
22546 Check_No_Identifiers
;
22547 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22548 Check_Valid_Configuration_Pragma
;
22549 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22550 DP
:= Fold_Upper
(Name_Buffer
(1));
22552 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
22553 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
22554 Lower_Val
:= Expr_Value
(Lower_Bound
);
22556 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
22557 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
22558 Upper_Val
:= Expr_Value
(Upper_Bound
);
22560 -- It is not allowed to use Task_Dispatching_Policy and
22561 -- Priority_Specific_Dispatching in the same partition.
22563 if Task_Dispatching_Policy
/= ' ' then
22564 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22566 ("pragma% incompatible with Task_Dispatching_Policy#");
22568 -- Check lower bound in range
22570 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
22572 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
22575 ("first_priority is out of range", Arg2
);
22577 -- Check upper bound in range
22579 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
22581 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
22584 ("last_priority is out of range", Arg3
);
22586 -- Check that the priority range is valid
22588 elsif Lower_Val
> Upper_Val
then
22590 ("last_priority_expression must be greater than or equal to "
22591 & "first_priority_expression");
22593 -- Store the new policy, but always preserve System_Location since
22594 -- we like the error message with the run-time name.
22597 -- Check overlapping in the priority ranges specified in other
22598 -- Priority_Specific_Dispatching pragmas within the same
22599 -- partition. We can only check those we know about.
22602 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
22604 if Specific_Dispatching
.Table
(J
).First_Priority
in
22605 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
22606 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
22607 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
22610 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
22612 ("priority range overlaps with "
22613 & "Priority_Specific_Dispatching#");
22617 -- The use of Priority_Specific_Dispatching is incompatible
22618 -- with Task_Dispatching_Policy.
22620 if Task_Dispatching_Policy
/= ' ' then
22621 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22623 ("Priority_Specific_Dispatching incompatible "
22624 & "with Task_Dispatching_Policy#");
22627 -- The use of Priority_Specific_Dispatching forces ceiling
22630 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
22631 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
22633 ("Priority_Specific_Dispatching incompatible "
22634 & "with Locking_Policy#");
22636 -- Set the Ceiling_Locking policy, but preserve System_Location
22637 -- since we like the error message with the run time name.
22640 Locking_Policy
:= 'C';
22642 if Locking_Policy_Sloc
/= System_Location
then
22643 Locking_Policy_Sloc
:= Loc
;
22647 -- Add entry in the table
22649 Specific_Dispatching
.Append
22650 ((Dispatching_Policy
=> DP
,
22651 First_Priority
=> UI_To_Int
(Lower_Val
),
22652 Last_Priority
=> UI_To_Int
(Upper_Val
),
22653 Pragma_Loc
=> Loc
));
22655 end Priority_Specific_Dispatching
;
22661 -- pragma Profile (profile_IDENTIFIER);
22663 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
22665 when Pragma_Profile
=>
22667 Check_Arg_Count
(1);
22668 Check_Valid_Configuration_Pragma
;
22669 Check_No_Identifiers
;
22672 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22675 if Nkind
(Argx
) /= N_Identifier
then
22677 ("argument of pragma Profile must be an identifier", N
);
22679 elsif Chars
(Argx
) = Name_Ravenscar
then
22680 Set_Ravenscar_Profile
(Ravenscar
, N
);
22682 elsif Chars
(Argx
) = Name_Jorvik
then
22683 Set_Ravenscar_Profile
(Jorvik
, N
);
22685 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
22686 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
22688 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
22689 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
22691 elsif Chars
(Argx
) = Name_Restricted
then
22692 Set_Profile_Restrictions
22694 N
, Warn
=> Treat_Restrictions_As_Warnings
);
22696 elsif Chars
(Argx
) = Name_Rational
then
22697 Set_Rational_Profile
;
22699 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
22700 Set_Profile_Restrictions
22701 (No_Implementation_Extensions
,
22702 N
, Warn
=> Treat_Restrictions_As_Warnings
);
22705 Error_Pragma_Arg
("& is not a valid profile", Argx
);
22709 ----------------------
22710 -- Profile_Warnings --
22711 ----------------------
22713 -- pragma Profile_Warnings (profile_IDENTIFIER);
22715 -- profile_IDENTIFIER => Restricted | Ravenscar
22717 when Pragma_Profile_Warnings
=>
22719 Check_Arg_Count
(1);
22720 Check_Valid_Configuration_Pragma
;
22721 Check_No_Identifiers
;
22724 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22727 if Chars
(Argx
) = Name_Ravenscar
then
22728 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
22730 elsif Chars
(Argx
) = Name_Restricted
then
22731 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
22733 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
22734 Set_Profile_Restrictions
22735 (No_Implementation_Extensions
, N
, Warn
=> True);
22738 Error_Pragma_Arg
("& is not a valid profile", Argx
);
22742 --------------------------
22743 -- Propagate_Exceptions --
22744 --------------------------
22746 -- pragma Propagate_Exceptions;
22748 -- Note: this pragma is obsolete and has no effect
22750 when Pragma_Propagate_Exceptions
=>
22752 Check_Arg_Count
(0);
22754 if Warn_On_Obsolescent_Feature
then
22756 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
22757 "and has no effect?j?", N
);
22760 -----------------------------
22761 -- Provide_Shift_Operators --
22762 -----------------------------
22764 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
22766 when Pragma_Provide_Shift_Operators
=>
22767 Provide_Shift_Operators
: declare
22770 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
22771 -- Insert declaration and pragma Instrinsic for named shift op
22773 ----------------------------
22774 -- Declare_Shift_Operator --
22775 ----------------------------
22777 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
22783 Make_Subprogram_Declaration
(Loc
,
22784 Make_Function_Specification
(Loc
,
22785 Defining_Unit_Name
=>
22786 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
22788 Result_Definition
=>
22789 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
22791 Parameter_Specifications
=> New_List
(
22792 Make_Parameter_Specification
(Loc
,
22793 Defining_Identifier
=>
22794 Make_Defining_Identifier
(Loc
, Name_Value
),
22796 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
22798 Make_Parameter_Specification
(Loc
,
22799 Defining_Identifier
=>
22800 Make_Defining_Identifier
(Loc
, Name_Amount
),
22802 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
22806 Chars
=> Name_Import
,
22807 Pragma_Argument_Associations
=> New_List
(
22808 Make_Pragma_Argument_Association
(Loc
,
22809 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
22810 Make_Pragma_Argument_Association
(Loc
,
22811 Expression
=> Make_Identifier
(Loc
, Nam
))));
22813 Insert_After
(N
, Import
);
22814 Insert_After
(N
, Func
);
22815 end Declare_Shift_Operator
;
22817 -- Start of processing for Provide_Shift_Operators
22821 Check_Arg_Count
(1);
22822 Check_Arg_Is_Local_Name
(Arg1
);
22824 Arg1
:= Get_Pragma_Arg
(Arg1
);
22826 -- We must have an entity name
22828 if not Is_Entity_Name
(Arg1
) then
22830 ("pragma % must apply to integer first subtype", Arg1
);
22833 -- If no Entity, means there was a prior error so ignore
22835 if Present
(Entity
(Arg1
)) then
22836 Ent
:= Entity
(Arg1
);
22838 -- Apply error checks
22840 if not Is_First_Subtype
(Ent
) then
22842 ("cannot apply pragma %",
22843 "\& is not a first subtype",
22846 elsif not Is_Integer_Type
(Ent
) then
22848 ("cannot apply pragma %",
22849 "\& is not an integer type",
22852 elsif Has_Shift_Operator
(Ent
) then
22854 ("cannot apply pragma %",
22855 "\& already has declared shift operators",
22858 elsif Is_Frozen
(Ent
) then
22860 ("pragma % appears too late",
22861 "\& is already frozen",
22865 -- Now declare the operators. We do this during analysis rather
22866 -- than expansion, since we want the operators available if we
22867 -- are operating in -gnatc mode.
22869 Declare_Shift_Operator
(Name_Rotate_Left
);
22870 Declare_Shift_Operator
(Name_Rotate_Right
);
22871 Declare_Shift_Operator
(Name_Shift_Left
);
22872 Declare_Shift_Operator
(Name_Shift_Right
);
22873 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
22875 end Provide_Shift_Operators
;
22881 -- pragma Psect_Object (
22882 -- [Internal =>] LOCAL_NAME,
22883 -- [, [External =>] EXTERNAL_SYMBOL]
22884 -- [, [Size =>] EXTERNAL_SYMBOL]);
22886 when Pragma_Common_Object
22887 | Pragma_Psect_Object
22889 Psect_Object
: declare
22890 Args
: Args_List
(1 .. 3);
22891 Names
: constant Name_List
(1 .. 3) := (
22896 Internal
: Node_Id
renames Args
(1);
22897 External
: Node_Id
renames Args
(2);
22898 Size
: Node_Id
renames Args
(3);
22900 Def_Id
: Entity_Id
;
22902 procedure Check_Arg
(Arg
: Node_Id
);
22903 -- Checks that argument is either a string literal or an
22904 -- identifier, and posts error message if not.
22910 procedure Check_Arg
(Arg
: Node_Id
) is
22912 if Nkind
(Original_Node
(Arg
)) not in
22913 N_String_Literal | N_Identifier
22916 ("inappropriate argument for pragma %", Arg
);
22920 -- Start of processing for Common_Object/Psect_Object
22924 Gather_Associations
(Names
, Args
);
22925 Process_Extended_Import_Export_Internal_Arg
(Internal
);
22927 Def_Id
:= Entity
(Internal
);
22929 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
22931 ("pragma% must designate an object", Internal
);
22934 Check_Arg
(Internal
);
22936 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
22938 ("cannot use pragma% for imported/exported object",
22942 if Is_Concurrent_Type
(Etype
(Internal
)) then
22944 ("cannot specify pragma % for task/protected object",
22948 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
22950 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
22952 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
22955 if Ekind
(Def_Id
) = E_Constant
then
22957 ("cannot specify pragma % for a constant", Internal
);
22960 if Is_Record_Type
(Etype
(Internal
)) then
22966 Ent
:= First_Entity
(Etype
(Internal
));
22967 while Present
(Ent
) loop
22968 Decl
:= Declaration_Node
(Ent
);
22970 if Ekind
(Ent
) = E_Component
22971 and then Nkind
(Decl
) = N_Component_Declaration
22972 and then Present
(Expression
(Decl
))
22973 and then Warn_On_Export_Import
22976 ("?x?object for pragma % has defaults", Internal
);
22986 if Present
(Size
) then
22990 if Present
(External
) then
22991 Check_Arg_Is_External_Name
(External
);
22994 -- If all error tests pass, link pragma on to the rep item chain
22996 Record_Rep_Item
(Def_Id
, N
);
23003 -- pragma Pure [(library_unit_NAME)];
23005 when Pragma_Pure
=> Pure
: declare
23009 Check_Ada_83_Warning
;
23011 -- If the pragma comes from a subprogram instantiation, nothing to
23012 -- check, this can happen at any level of nesting.
23014 if Is_Wrapper_Package
(Current_Scope
) then
23018 Check_Valid_Library_Unit_Pragma
;
23020 -- If N was rewritten as a null statement there is nothing more
23023 if Nkind
(N
) = N_Null_Statement
then
23027 Ent
:= Find_Lib_Unit_Name
;
23029 -- A pragma that applies to a Ghost entity becomes Ghost for the
23030 -- purposes of legality checks and removal of ignored Ghost code.
23032 Mark_Ghost_Pragma
(N
, Ent
);
23034 if not Debug_Flag_U
then
23036 Set_Has_Pragma_Pure
(Ent
);
23038 if Legacy_Elaboration_Checks
then
23039 Set_Suppress_Elaboration_Warnings
(Ent
);
23044 -------------------
23045 -- Pure_Function --
23046 -------------------
23048 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
23050 when Pragma_Pure_Function
=> Pure_Function
: declare
23051 Def_Id
: Entity_Id
;
23054 Effective
: Boolean := False;
23055 Orig_Def
: Entity_Id
;
23056 Same_Decl
: Boolean := False;
23060 Check_Arg_Count
(1);
23061 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23062 Check_Arg_Is_Local_Name
(Arg1
);
23063 E_Id
:= Get_Pragma_Arg
(Arg1
);
23065 if Etype
(E_Id
) = Any_Type
then
23069 -- Loop through homonyms (overloadings) of referenced entity
23071 E
:= Entity
(E_Id
);
23073 Analyze_If_Present
(Pragma_Side_Effects
);
23075 -- A function with side-effects shall not have a Pure_Function
23076 -- aspect or pragma (SPARK RM 6.1.11(5)).
23078 if Is_Function_With_Side_Effects
(E
) then
23080 ("pragma % incompatible with ""Side_Effects""");
23083 -- A pragma that applies to a Ghost entity becomes Ghost for the
23084 -- purposes of legality checks and removal of ignored Ghost code.
23086 Mark_Ghost_Pragma
(N
, E
);
23088 if Present
(E
) then
23090 Def_Id
:= Get_Base_Subprogram
(E
);
23092 if Ekind
(Def_Id
) not in
23093 E_Function | E_Generic_Function | E_Operator
23096 ("pragma% requires a function name", Arg1
);
23099 -- When we have a generic function we must jump up a level
23100 -- to the declaration of the wrapper package itself.
23102 Orig_Def
:= Def_Id
;
23104 if Is_Generic_Instance
(Def_Id
) then
23105 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
23106 Orig_Def
:= Parent
(Orig_Def
);
23110 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
23112 Set_Is_Pure
(Def_Id
);
23114 if not Has_Pragma_Pure_Function
(Def_Id
) then
23115 Set_Has_Pragma_Pure_Function
(Def_Id
);
23120 exit when From_Aspect_Specification
(N
);
23122 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
23126 and then Warn_On_Redundant_Constructs
23129 ("pragma Pure_Function on& is redundant?r?",
23132 elsif not Same_Decl
then
23134 ("pragma% argument must be in same declarative part",
23140 --------------------
23141 -- Queuing_Policy --
23142 --------------------
23144 -- pragma Queuing_Policy (policy_IDENTIFIER);
23146 when Pragma_Queuing_Policy
=> declare
23150 Check_Ada_83_Warning
;
23151 Check_Arg_Count
(1);
23152 Check_No_Identifiers
;
23153 Check_Arg_Is_Queuing_Policy
(Arg1
);
23154 Check_Valid_Configuration_Pragma
;
23155 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23156 QP
:= Fold_Upper
(Name_Buffer
(1));
23158 if Queuing_Policy
/= ' '
23159 and then Queuing_Policy
/= QP
23161 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
23162 Error_Pragma
("queuing policy incompatible with policy#");
23164 -- Set new policy, but always preserve System_Location since we
23165 -- like the error message with the run time name.
23168 Queuing_Policy
:= QP
;
23170 if Queuing_Policy_Sloc
/= System_Location
then
23171 Queuing_Policy_Sloc
:= Loc
;
23180 -- pragma Rational, for compatibility with foreign compiler
23182 when Pragma_Rational
=>
23183 Set_Rational_Profile
;
23185 ---------------------
23186 -- Refined_Depends --
23187 ---------------------
23189 -- pragma Refined_Depends (DEPENDENCY_RELATION);
23191 -- DEPENDENCY_RELATION ::=
23193 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
23195 -- DEPENDENCY_CLAUSE ::=
23196 -- OUTPUT_LIST =>[+] INPUT_LIST
23197 -- | NULL_DEPENDENCY_CLAUSE
23199 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
23201 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
23203 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
23205 -- OUTPUT ::= NAME | FUNCTION_RESULT
23208 -- where FUNCTION_RESULT is a function Result attribute_reference
23210 -- Characteristics:
23212 -- * Analysis - The annotation undergoes initial checks to verify
23213 -- the legal placement and context. Secondary checks fully analyze
23214 -- the dependency clauses/global list in:
23216 -- Analyze_Refined_Depends_In_Decl_Part
23218 -- * Expansion - None.
23220 -- * Template - The annotation utilizes the generic template of the
23221 -- related subprogram body.
23223 -- * Globals - Capture of global references must occur after full
23226 -- * Instance - The annotation is instantiated automatically when
23227 -- the related generic subprogram body is instantiated.
23229 when Pragma_Refined_Depends
=> Refined_Depends
: declare
23230 Body_Id
: Entity_Id
;
23232 Spec_Id
: Entity_Id
;
23235 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23239 -- Chain the pragma on the contract for further processing by
23240 -- Analyze_Refined_Depends_In_Decl_Part.
23242 Add_Contract_Item
(N
, Body_Id
);
23244 -- The legality checks of pragmas Refined_Depends and
23245 -- Refined_Global are affected by the SPARK mode in effect and
23246 -- the volatility of the context. In addition these two pragmas
23247 -- are subject to an inherent order:
23249 -- 1) Refined_Global
23250 -- 2) Refined_Depends
23252 -- Analyze all these pragmas in the order outlined above
23254 Analyze_If_Present
(Pragma_SPARK_Mode
);
23255 Analyze_If_Present
(Pragma_Volatile_Function
);
23256 Analyze_If_Present
(Pragma_Side_Effects
);
23257 Analyze_If_Present
(Pragma_Refined_Global
);
23258 Analyze_Refined_Depends_In_Decl_Part
(N
);
23260 end Refined_Depends
;
23262 --------------------
23263 -- Refined_Global --
23264 --------------------
23266 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
23268 -- GLOBAL_SPECIFICATION ::=
23271 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
23273 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
23275 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
23276 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
23277 -- GLOBAL_ITEM ::= NAME
23279 -- Characteristics:
23281 -- * Analysis - The annotation undergoes initial checks to verify
23282 -- the legal placement and context. Secondary checks fully analyze
23283 -- the dependency clauses/global list in:
23285 -- Analyze_Refined_Global_In_Decl_Part
23287 -- * Expansion - None.
23289 -- * Template - The annotation utilizes the generic template of the
23290 -- related subprogram body.
23292 -- * Globals - Capture of global references must occur after full
23295 -- * Instance - The annotation is instantiated automatically when
23296 -- the related generic subprogram body is instantiated.
23298 when Pragma_Refined_Global
=> Refined_Global
: declare
23299 Body_Id
: Entity_Id
;
23301 Spec_Id
: Entity_Id
;
23304 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23308 -- Chain the pragma on the contract for further processing by
23309 -- Analyze_Refined_Global_In_Decl_Part.
23311 Add_Contract_Item
(N
, Body_Id
);
23313 -- The legality checks of pragmas Refined_Depends and
23314 -- Refined_Global are affected by the SPARK mode in effect and
23315 -- the volatility of the context. In addition these two pragmas
23316 -- are subject to an inherent order:
23318 -- 1) Refined_Global
23319 -- 2) Refined_Depends
23321 -- Analyze all these pragmas in the order outlined above
23323 Analyze_If_Present
(Pragma_SPARK_Mode
);
23324 Analyze_If_Present
(Pragma_Volatile_Function
);
23325 Analyze_If_Present
(Pragma_Side_Effects
);
23326 Analyze_Refined_Global_In_Decl_Part
(N
);
23327 Analyze_If_Present
(Pragma_Refined_Depends
);
23329 end Refined_Global
;
23335 -- pragma Refined_Post (boolean_EXPRESSION);
23337 -- Characteristics:
23339 -- * Analysis - The annotation is fully analyzed immediately upon
23340 -- elaboration as it cannot forward reference entities.
23342 -- * Expansion - The annotation is expanded during the expansion of
23343 -- the related subprogram body contract as performed in:
23345 -- Expand_Subprogram_Contract
23347 -- * Template - The annotation utilizes the generic template of the
23348 -- related subprogram body.
23350 -- * Globals - Capture of global references must occur after full
23353 -- * Instance - The annotation is instantiated automatically when
23354 -- the related generic subprogram body is instantiated.
23356 when Pragma_Refined_Post
=> Refined_Post
: declare
23357 Body_Id
: Entity_Id
;
23359 Spec_Id
: Entity_Id
;
23362 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
23364 -- Fully analyze the pragma when it appears inside a subprogram
23365 -- body because it cannot benefit from forward references.
23369 -- Chain the pragma on the contract for completeness
23371 Add_Contract_Item
(N
, Body_Id
);
23373 -- The legality checks of pragma Refined_Post are affected by
23374 -- the SPARK mode in effect and the volatility of the context.
23375 -- Analyze all pragmas in a specific order.
23377 Analyze_If_Present
(Pragma_SPARK_Mode
);
23378 Analyze_If_Present
(Pragma_Volatile_Function
);
23379 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
23381 -- Currently it is not possible to inline pre/postconditions on
23382 -- a subprogram subject to pragma Inline_Always.
23384 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
23388 -------------------
23389 -- Refined_State --
23390 -------------------
23392 -- pragma Refined_State (REFINEMENT_LIST);
23394 -- REFINEMENT_LIST ::=
23395 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
23397 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
23399 -- CONSTITUENT_LIST ::=
23402 -- | (CONSTITUENT {, CONSTITUENT})
23404 -- CONSTITUENT ::= object_NAME | state_NAME
23406 -- Characteristics:
23408 -- * Analysis - The annotation undergoes initial checks to verify
23409 -- the legal placement and context. Secondary checks preanalyze the
23410 -- refinement clauses in:
23412 -- Analyze_Refined_State_In_Decl_Part
23414 -- * Expansion - None.
23416 -- * Template - The annotation utilizes the template of the related
23419 -- * Globals - Capture of global references must occur after full
23422 -- * Instance - The annotation is instantiated automatically when
23423 -- the related generic package body is instantiated.
23425 when Pragma_Refined_State
=> Refined_State
: declare
23426 Pack_Decl
: Node_Id
;
23427 Spec_Id
: Entity_Id
;
23431 Check_No_Identifiers
;
23432 Check_Arg_Count
(1);
23434 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
23436 if Nkind
(Pack_Decl
) /= N_Package_Body
then
23440 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
23442 -- A pragma that applies to a Ghost entity becomes Ghost for the
23443 -- purposes of legality checks and removal of ignored Ghost code.
23445 Mark_Ghost_Pragma
(N
, Spec_Id
);
23447 -- Chain the pragma on the contract for further processing by
23448 -- Analyze_Refined_State_In_Decl_Part.
23450 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
23452 -- The legality checks of pragma Refined_State are affected by the
23453 -- SPARK mode in effect. Analyze all pragmas in a specific order.
23455 Analyze_If_Present
(Pragma_SPARK_Mode
);
23457 -- State refinement is allowed only when the corresponding package
23458 -- declaration has non-null pragma Abstract_State. Refinement not
23459 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
23461 if SPARK_Mode
/= Off
23463 (No
(Abstract_States
(Spec_Id
))
23464 or else Has_Null_Abstract_State
(Spec_Id
))
23467 ("useless refinement, package & does not define abstract "
23468 & "states", N
, Spec_Id
);
23473 -----------------------
23474 -- Relative_Deadline --
23475 -----------------------
23477 -- pragma Relative_Deadline (time_span_EXPRESSION);
23479 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
23480 P
: constant Node_Id
:= Parent
(N
);
23485 Check_No_Identifiers
;
23486 Check_Arg_Count
(1);
23488 Arg
:= Get_Pragma_Arg
(Arg1
);
23490 -- The expression must be analyzed in the special manner described
23491 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
23493 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
23497 if Nkind
(P
) = N_Subprogram_Body
then
23498 Check_In_Main_Program
;
23500 -- Only Task and subprogram cases allowed
23502 elsif Nkind
(P
) /= N_Task_Definition
then
23506 -- Check duplicate pragma before we set the corresponding flag
23508 if Has_Relative_Deadline_Pragma
(P
) then
23509 Error_Pragma
("duplicate pragma% not allowed");
23512 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
23513 -- Relative_Deadline pragma node cannot be inserted in the Rep
23514 -- Item chain of Ent since it is rewritten by the expander as a
23515 -- procedure call statement that will break the chain.
23517 Set_Has_Relative_Deadline_Pragma
(P
);
23518 end Relative_Deadline
;
23520 ------------------------
23521 -- Remote_Access_Type --
23522 ------------------------
23524 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
23526 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
23531 Check_Arg_Count
(1);
23532 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23533 Check_Arg_Is_Local_Name
(Arg1
);
23535 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
23537 -- A pragma that applies to a Ghost entity becomes Ghost for the
23538 -- purposes of legality checks and removal of ignored Ghost code.
23540 Mark_Ghost_Pragma
(N
, E
);
23542 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
23543 and then Ekind
(E
) = E_General_Access_Type
23544 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
23545 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
23547 and then Is_Valid_Remote_Object_Type
23548 (Root_Type
(Directly_Designated_Type
(E
)))
23550 Set_Is_Remote_Types
(E
);
23554 ("pragma% applies only to formal access-to-class-wide types",
23557 end Remote_Access_Type
;
23559 ---------------------------
23560 -- Remote_Call_Interface --
23561 ---------------------------
23563 -- pragma Remote_Call_Interface [(library_unit_NAME)];
23565 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
23566 Cunit_Node
: Node_Id
;
23567 Cunit_Ent
: Entity_Id
;
23571 Check_Ada_83_Warning
;
23572 Check_Valid_Library_Unit_Pragma
;
23574 -- If N was rewritten as a null statement there is nothing more
23577 if Nkind
(N
) = N_Null_Statement
then
23581 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23582 K
:= Nkind
(Unit
(Cunit_Node
));
23583 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23585 -- A pragma that applies to a Ghost entity becomes Ghost for the
23586 -- purposes of legality checks and removal of ignored Ghost code.
23588 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23590 if K
= N_Package_Declaration
23591 or else K
= N_Generic_Package_Declaration
23592 or else K
= N_Subprogram_Declaration
23593 or else K
= N_Generic_Subprogram_Declaration
23594 or else (K
= N_Subprogram_Body
23595 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
23600 "pragma% must apply to package or subprogram declaration");
23603 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
23604 end Remote_Call_Interface
;
23610 -- pragma Remote_Types [(library_unit_NAME)];
23612 when Pragma_Remote_Types
=> Remote_Types
: declare
23613 Cunit_Node
: Node_Id
;
23614 Cunit_Ent
: Entity_Id
;
23617 Check_Ada_83_Warning
;
23618 Check_Valid_Library_Unit_Pragma
;
23620 -- If N was rewritten as a null statement there is nothing more
23623 if Nkind
(N
) = N_Null_Statement
then
23627 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23628 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23630 -- A pragma that applies to a Ghost entity becomes Ghost for the
23631 -- purposes of legality checks and removal of ignored Ghost code.
23633 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23635 if Nkind
(Unit
(Cunit_Node
)) not in
23636 N_Package_Declaration | N_Generic_Package_Declaration
23639 ("pragma% can only apply to a package declaration");
23642 Set_Is_Remote_Types
(Cunit_Ent
);
23649 -- pragma Ravenscar;
23651 when Pragma_Ravenscar
=>
23653 Check_Arg_Count
(0);
23654 Check_Valid_Configuration_Pragma
;
23655 Set_Ravenscar_Profile
(Ravenscar
, N
);
23657 if Warn_On_Obsolescent_Feature
then
23659 ("pragma Ravenscar is an obsolescent feature?j?", N
);
23661 ("|use pragma Profile (Ravenscar) instead?j?", N
);
23664 -------------------------
23665 -- Restricted_Run_Time --
23666 -------------------------
23668 -- pragma Restricted_Run_Time;
23670 when Pragma_Restricted_Run_Time
=>
23672 Check_Arg_Count
(0);
23673 Check_Valid_Configuration_Pragma
;
23674 Set_Profile_Restrictions
23675 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
23677 if Warn_On_Obsolescent_Feature
then
23679 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
23682 ("|use pragma Profile (Restricted) instead?j?", N
);
23689 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
23692 -- restriction_IDENTIFIER
23693 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23695 when Pragma_Restrictions
=>
23696 Process_Restrictions_Or_Restriction_Warnings
23697 (Warn
=> Treat_Restrictions_As_Warnings
);
23699 --------------------------
23700 -- Restriction_Warnings --
23701 --------------------------
23703 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
23706 -- restriction_IDENTIFIER
23707 -- | restriction_parameter_IDENTIFIER => EXPRESSION
23709 when Pragma_Restriction_Warnings
=>
23711 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
23717 -- pragma Reviewable;
23719 when Pragma_Reviewable
=>
23720 Check_Ada_83_Warning
;
23721 Check_Arg_Count
(0);
23723 -- Call dummy debugging function rv. This is done to assist front
23724 -- end debugging. By placing a Reviewable pragma in the source
23725 -- program, a breakpoint on rv catches this place in the source,
23726 -- allowing convenient stepping to the point of interest.
23730 --------------------------
23731 -- Secondary_Stack_Size --
23732 --------------------------
23734 -- pragma Secondary_Stack_Size (EXPRESSION);
23736 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
23737 P
: constant Node_Id
:= Parent
(N
);
23743 Check_No_Identifiers
;
23744 Check_Arg_Count
(1);
23746 if Nkind
(P
) = N_Task_Definition
then
23747 Arg
:= Get_Pragma_Arg
(Arg1
);
23748 Ent
:= Defining_Identifier
(Parent
(P
));
23750 -- The expression must be analyzed in the special manner
23751 -- described in "Handling of Default Expressions" in sem.ads.
23753 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23755 -- The pragma cannot appear if the No_Secondary_Stack
23756 -- restriction is in effect.
23758 Check_Restriction
(No_Secondary_Stack
, Arg
);
23760 -- Anything else is incorrect
23766 -- Check duplicate pragma before we chain the pragma in the Rep
23767 -- Item chain of Ent.
23769 Check_Duplicate_Pragma
(Ent
);
23770 Record_Rep_Item
(Ent
, N
);
23771 end Secondary_Stack_Size
;
23773 --------------------------
23774 -- Short_Circuit_And_Or --
23775 --------------------------
23777 -- pragma Short_Circuit_And_Or;
23779 when Pragma_Short_Circuit_And_Or
=>
23781 Check_Arg_Count
(0);
23782 Check_Valid_Configuration_Pragma
;
23783 Short_Circuit_And_Or
:= True;
23785 -------------------
23786 -- Share_Generic --
23787 -------------------
23789 -- pragma Share_Generic (GNAME {, GNAME});
23791 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23793 when Pragma_Share_Generic
=>
23795 Process_Generic_List
;
23801 -- pragma Shared (LOCAL_NAME);
23803 when Pragma_Shared
=>
23805 Process_Atomic_Independent_Shared_Volatile
;
23807 --------------------
23808 -- Shared_Passive --
23809 --------------------
23811 -- pragma Shared_Passive [(library_unit_NAME)];
23813 -- Set the flag Is_Shared_Passive of program unit name entity
23815 when Pragma_Shared_Passive
=> Shared_Passive
: declare
23816 Cunit_Node
: Node_Id
;
23817 Cunit_Ent
: Entity_Id
;
23820 Check_Ada_83_Warning
;
23821 Check_Valid_Library_Unit_Pragma
;
23823 -- If N was rewritten as a null statement there is nothing more
23826 if Nkind
(N
) = N_Null_Statement
then
23830 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23831 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23833 -- A pragma that applies to a Ghost entity becomes Ghost for the
23834 -- purposes of legality checks and removal of ignored Ghost code.
23836 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23838 if Nkind
(Unit
(Cunit_Node
)) not in
23839 N_Package_Declaration | N_Generic_Package_Declaration
23842 ("pragma% can only apply to a package declaration");
23845 Set_Is_Shared_Passive
(Cunit_Ent
);
23846 end Shared_Passive
;
23848 -----------------------
23849 -- Short_Descriptors --
23850 -----------------------
23852 -- pragma Short_Descriptors;
23854 -- Recognize and validate, but otherwise ignore
23856 when Pragma_Short_Descriptors
=>
23858 Check_Arg_Count
(0);
23859 Check_Valid_Configuration_Pragma
;
23865 -- pragma Side_Effects [ (boolean_EXPRESSION) ];
23867 -- Characteristics:
23869 -- * Analysis - The annotation is fully analyzed immediately upon
23870 -- elaboration as its expression must be static.
23872 -- * Expansion - None.
23874 -- * Template - The annotation utilizes the generic template of the
23875 -- related subprogram [body] when it is:
23877 -- aspect on subprogram declaration
23878 -- aspect on stand-alone subprogram body
23879 -- pragma on stand-alone subprogram body
23881 -- The annotation must prepare its own template when it is:
23883 -- pragma on subprogram declaration
23885 -- * Globals - Capture of global references must occur after full
23888 -- * Instance - The annotation is instantiated automatically when
23889 -- the related generic subprogram [body] is instantiated except for
23890 -- the "pragma on subprogram declaration" case. In that scenario
23891 -- the annotation must instantiate itself.
23893 when Pragma_Side_Effects
=> Side_Effects
: declare
23894 Subp_Decl
: Node_Id
;
23895 Spec_Id
: Entity_Id
;
23896 Over_Id
: Entity_Id
;
23900 Check_No_Identifiers
;
23901 Check_At_Most_N_Arguments
(1);
23904 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23906 -- Abstract subprogram declaration
23908 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23911 -- Generic subprogram declaration
23913 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23916 -- Body acts as spec
23918 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23919 and then No
(Corresponding_Spec
(Subp_Decl
))
23923 -- Body stub acts as spec
23925 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23926 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23930 -- Subprogram declaration
23932 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23935 -- Otherwise the pragma is associated with an illegal construct
23938 Error_Pragma
("pragma % must apply to a subprogram");
23941 if Nkind
(Specification
(Subp_Decl
)) /= N_Function_Specification
23943 Error_Pragma
("pragma % must apply to a function");
23946 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23948 -- Chain the pragma on the contract for completeness
23950 Add_Contract_Item
(N
, Spec_Id
);
23952 -- A function with side-effects cannot override a function without
23953 -- side-effects (SPARK RM 7.1.2(16)). Overriding checks are
23954 -- usually performed in New_Overloaded_Entity, however at
23955 -- that point the pragma has not been processed yet.
23957 Over_Id
:= Overridden_Operation
(Spec_Id
);
23959 if Present
(Over_Id
)
23960 and then not Is_Function_With_Side_Effects
(Over_Id
)
23963 ("incompatible declaration of side-effects for function",
23966 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23968 ("\& declared # with Side_Effects value False",
23971 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23973 ("\overridden # with Side_Effects value True",
23977 -- Analyze the Boolean expression (if any)
23979 if Present
(Arg1
) then
23980 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23984 ------------------------------
23985 -- Simple_Storage_Pool_Type --
23986 ------------------------------
23988 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23990 when Pragma_Simple_Storage_Pool_Type
=>
23991 Simple_Storage_Pool_Type
: declare
23997 Check_Arg_Count
(1);
23998 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24000 Type_Id
:= Get_Pragma_Arg
(Arg1
);
24001 Find_Type
(Type_Id
);
24002 Typ
:= Entity
(Type_Id
);
24004 if Typ
= Any_Type
then
24008 -- A pragma that applies to a Ghost entity becomes Ghost for the
24009 -- purposes of legality checks and removal of ignored Ghost code.
24011 Mark_Ghost_Pragma
(N
, Typ
);
24013 -- We require the pragma to apply to a type declared in a package
24014 -- declaration, but not (immediately) within a package body.
24016 if Ekind
(Current_Scope
) /= E_Package
24017 or else In_Package_Body
(Current_Scope
)
24020 ("pragma% can only apply to type declared immediately "
24021 & "within a package declaration");
24024 -- A simple storage pool type must be an immutably limited record
24025 -- or private type. If the pragma is given for a private type,
24026 -- the full type is similarly restricted (which is checked later
24027 -- in Freeze_Entity).
24029 if Is_Record_Type
(Typ
)
24030 and then not Is_Inherently_Limited_Type
(Typ
)
24033 ("pragma% can only apply to explicitly limited record type");
24035 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
24037 ("pragma% can only apply to a private type that is limited");
24039 elsif not Is_Record_Type
(Typ
)
24040 and then not Is_Private_Type
(Typ
)
24043 ("pragma% can only apply to limited record or private type");
24046 Record_Rep_Item
(Typ
, N
);
24047 end Simple_Storage_Pool_Type
;
24049 ----------------------
24050 -- Source_File_Name --
24051 ----------------------
24053 -- There are five forms for this pragma:
24055 -- pragma Source_File_Name (
24056 -- [UNIT_NAME =>] unit_NAME,
24057 -- BODY_FILE_NAME => STRING_LITERAL
24058 -- [, [INDEX =>] INTEGER_LITERAL]);
24060 -- pragma Source_File_Name (
24061 -- [UNIT_NAME =>] unit_NAME,
24062 -- SPEC_FILE_NAME => STRING_LITERAL
24063 -- [, [INDEX =>] INTEGER_LITERAL]);
24065 -- pragma Source_File_Name (
24066 -- BODY_FILE_NAME => STRING_LITERAL
24067 -- [, DOT_REPLACEMENT => STRING_LITERAL]
24068 -- [, CASING => CASING_SPEC]);
24070 -- pragma Source_File_Name (
24071 -- SPEC_FILE_NAME => STRING_LITERAL
24072 -- [, DOT_REPLACEMENT => STRING_LITERAL]
24073 -- [, CASING => CASING_SPEC]);
24075 -- pragma Source_File_Name (
24076 -- SUBUNIT_FILE_NAME => STRING_LITERAL
24077 -- [, DOT_REPLACEMENT => STRING_LITERAL]
24078 -- [, CASING => CASING_SPEC]);
24080 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
24082 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
24083 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
24084 -- only be used when no project file is used, while SFNP can only be
24085 -- used when a project file is used.
24087 -- No processing here. Processing was completed during parsing, since
24088 -- we need to have file names set as early as possible. Units are
24089 -- loaded well before semantic processing starts.
24091 -- The only processing we defer to this point is the check for
24092 -- correct placement.
24094 when Pragma_Source_File_Name
=>
24096 Check_Valid_Configuration_Pragma
;
24098 ------------------------------
24099 -- Source_File_Name_Project --
24100 ------------------------------
24102 -- See Source_File_Name for syntax
24104 -- No processing here. Processing was completed during parsing, since
24105 -- we need to have file names set as early as possible. Units are
24106 -- loaded well before semantic processing starts.
24108 -- The only processing we defer to this point is the check for
24109 -- correct placement.
24111 when Pragma_Source_File_Name_Project
=>
24113 Check_Valid_Configuration_Pragma
;
24115 -- Check that a pragma Source_File_Name_Project is used only in a
24116 -- configuration pragmas file.
24118 -- Pragmas Source_File_Name_Project should only be generated by
24119 -- the Project Manager in configuration pragmas files.
24121 -- This is really an ugly test. It seems to depend on some
24122 -- accidental and undocumented property. At the very least it
24123 -- needs to be documented, but it would be better to have a
24124 -- clean way of testing if we are in a configuration file???
24126 if Present
(Parent
(N
)) then
24128 ("pragma% can only appear in a configuration pragmas file");
24131 ----------------------
24132 -- Source_Reference --
24133 ----------------------
24135 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
24137 -- Nothing to do, all processing completed in Par.Prag, since we need
24138 -- the information for possible parser messages that are output.
24140 when Pragma_Source_Reference
=>
24147 -- pragma SPARK_Mode [(Auto | On | Off)];
24149 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
24150 Mode_Id
: SPARK_Mode_Type
;
24152 procedure Check_Pragma_Conformance
24153 (Context_Pragma
: Node_Id
;
24154 Entity
: Entity_Id
;
24155 Entity_Pragma
: Node_Id
);
24156 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
24157 -- conformance of pragma N depending the following scenarios:
24159 -- If pragma Context_Pragma is not Empty, verify that pragma N is
24160 -- compatible with the pragma Context_Pragma that was inherited
24161 -- from the context:
24162 -- * If the mode of Context_Pragma is ON, then the new mode can
24164 -- * If the mode of Context_Pragma is OFF, then the only allowed
24165 -- new mode is also OFF. Emit error if this is not the case.
24167 -- If Entity is not Empty, verify that pragma N is compatible with
24168 -- pragma Entity_Pragma that belongs to Entity.
24169 -- * If Entity_Pragma is Empty, always issue an error as this
24170 -- corresponds to the case where a previous section of Entity
24171 -- has no SPARK_Mode set.
24172 -- * If the mode of Entity_Pragma is ON, then the new mode can
24174 -- * If the mode of Entity_Pragma is OFF, then the only allowed
24175 -- new mode is also OFF. Emit error if this is not the case.
24177 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
24178 -- Subsidiary to routines Process_xxx. Verify that the related
24179 -- entity E subject to pragma SPARK_Mode is library-level.
24181 procedure Process_Body
(Decl
: Node_Id
);
24182 -- Verify the legality of pragma SPARK_Mode when it appears as the
24183 -- top of the body declarations of entry, package, protected unit,
24184 -- subprogram or task unit body denoted by Decl.
24186 procedure Process_Overloadable
(Decl
: Node_Id
);
24187 -- Verify the legality of pragma SPARK_Mode when it applies to an
24188 -- entry or [generic] subprogram declaration denoted by Decl.
24190 procedure Process_Private_Part
(Decl
: Node_Id
);
24191 -- Verify the legality of pragma SPARK_Mode when it appears at the
24192 -- top of the private declarations of a package spec, protected or
24193 -- task unit declaration denoted by Decl.
24195 procedure Process_Statement_Part
(Decl
: Node_Id
);
24196 -- Verify the legality of pragma SPARK_Mode when it appears at the
24197 -- top of the statement sequence of a package body denoted by node
24200 procedure Process_Visible_Part
(Decl
: Node_Id
);
24201 -- Verify the legality of pragma SPARK_Mode when it appears at the
24202 -- top of the visible declarations of a package spec, protected or
24203 -- task unit declaration denoted by Decl. The routine is also used
24204 -- on protected or task units declared without a definition.
24206 procedure Set_SPARK_Context
;
24207 -- Subsidiary to routines Process_xxx. Set the global variables
24208 -- which represent the mode of the context from pragma N. Ensure
24209 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
24211 ------------------------------
24212 -- Check_Pragma_Conformance --
24213 ------------------------------
24215 procedure Check_Pragma_Conformance
24216 (Context_Pragma
: Node_Id
;
24217 Entity
: Entity_Id
;
24218 Entity_Pragma
: Node_Id
)
24220 Err_Id
: Entity_Id
;
24224 -- The current pragma may appear without an argument. If this
24225 -- is the case, associate all error messages with the pragma
24228 if Present
(Arg1
) then
24234 -- The mode of the current pragma is compared against that of
24235 -- an enclosing context.
24237 if Present
(Context_Pragma
) then
24238 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
24240 -- Issue an error if the new mode is less restrictive than
24241 -- that of the context.
24243 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
24244 and then Get_SPARK_Mode_From_Annotation
(N
) = On
24247 ("cannot change SPARK_Mode from Off to On", Err_N
);
24248 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
24249 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
24254 -- The mode of the current pragma is compared against that of
24255 -- an initial package, protected type, subprogram or task type
24258 if Present
(Entity
) then
24260 -- A simple protected or task type is transformed into an
24261 -- anonymous type whose name cannot be used to issue error
24262 -- messages. Recover the original entity of the type.
24264 if Ekind
(Entity
) in E_Protected_Type | E_Task_Type
then
24267 (Original_Node
(Unit_Declaration_Node
(Entity
)));
24272 -- Both the initial declaration and the completion carry
24273 -- SPARK_Mode pragmas.
24275 if Present
(Entity_Pragma
) then
24276 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
24278 -- Issue an error if the new mode is less restrictive
24279 -- than that of the initial declaration.
24281 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
24282 and then Get_SPARK_Mode_From_Annotation
(N
) = On
24284 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
24285 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
24287 ("\value Off was set for SPARK_Mode on&#",
24292 -- Otherwise the initial declaration lacks a SPARK_Mode
24293 -- pragma in which case the current pragma is illegal as
24294 -- it cannot "complete".
24296 elsif Get_SPARK_Mode_From_Annotation
(N
) = Off
24297 and then (Is_Generic_Unit
(Entity
) or else In_Instance
)
24302 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
24303 Error_Msg_Sloc
:= Sloc
(Err_Id
);
24305 ("\no value was set for SPARK_Mode on&#",
24310 end Check_Pragma_Conformance
;
24312 --------------------------------
24313 -- Check_Library_Level_Entity --
24314 --------------------------------
24316 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
24317 procedure Add_Entity_To_Name_Buffer
;
24318 -- Add the E_Kind of entity E to the name buffer
24320 -------------------------------
24321 -- Add_Entity_To_Name_Buffer --
24322 -------------------------------
24324 procedure Add_Entity_To_Name_Buffer
is
24326 if Ekind
(E
) in E_Entry | E_Entry_Family
then
24327 Add_Str_To_Name_Buffer
("entry");
24329 elsif Ekind
(E
) in E_Generic_Package
24333 Add_Str_To_Name_Buffer
("package");
24335 elsif Ekind
(E
) in E_Protected_Body | E_Protected_Type
then
24336 Add_Str_To_Name_Buffer
("protected type");
24338 elsif Ekind
(E
) in E_Function
24339 | E_Generic_Function
24340 | E_Generic_Procedure
24342 | E_Subprogram_Body
24344 Add_Str_To_Name_Buffer
("subprogram");
24347 pragma Assert
(Ekind
(E
) in E_Task_Body | E_Task_Type
);
24348 Add_Str_To_Name_Buffer
("task type");
24350 end Add_Entity_To_Name_Buffer
;
24354 Msg_1
: constant String :=
24355 "incorrect placement of pragma% with value ""On"" '[[]']";
24358 -- Start of processing for Check_Library_Level_Entity
24361 -- A SPARK_Mode of On shall only apply to library-level
24362 -- entities, except for those in generic instances, which are
24363 -- ignored (even if the entity gets SPARK_Mode pragma attached
24364 -- in the AST, its effect is not taken into account unless the
24365 -- context already provides SPARK_Mode of On in GNATprove).
24367 if Get_SPARK_Mode_From_Annotation
(N
) = On
24368 and then not Is_Library_Level_Entity
(E
)
24369 and then Instantiation_Location
(Sloc
(N
)) = No_Location
24371 Error_Msg_Name_1
:= Pname
;
24372 Error_Msg_Code
:= GEC_SPARK_Mode_On_Not_Library_Level
;
24373 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
24376 Add_Str_To_Name_Buffer
("\& is not a library-level ");
24377 Add_Entity_To_Name_Buffer
;
24379 Msg_2
:= Name_Find
;
24380 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
24384 end Check_Library_Level_Entity
;
24390 procedure Process_Body
(Decl
: Node_Id
) is
24391 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24392 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
24395 -- Ignore pragma when applied to the special body created
24396 -- for inlining, recognized by its internal name _Parent; or
24397 -- when applied to the special body created for contracts,
24398 -- recognized by its internal name _Wrapped_Statements.
24400 if Chars
(Body_Id
) in Name_uParent
24401 | Name_uWrapped_Statements
24406 Check_Library_Level_Entity
(Body_Id
);
24408 -- For entry bodies, verify the legality against:
24409 -- * The mode of the context
24410 -- * The mode of the spec (if any)
24412 if Nkind
(Decl
) in N_Entry_Body | N_Subprogram_Body
then
24414 -- A stand-alone subprogram body
24416 if Body_Id
= Spec_Id
then
24417 Check_Pragma_Conformance
24418 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24420 Entity_Pragma
=> Empty
);
24422 -- An entry or subprogram body that completes a previous
24426 Check_Pragma_Conformance
24427 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24429 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
24433 Set_SPARK_Pragma
(Body_Id
, N
);
24434 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24436 -- For package bodies, verify the legality against:
24437 -- * The mode of the context
24438 -- * The mode of the private part
24440 -- This case is separated from protected and task bodies
24441 -- because the statement part of the package body inherits
24442 -- the mode of the body declarations.
24444 elsif Nkind
(Decl
) = N_Package_Body
then
24445 Check_Pragma_Conformance
24446 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24448 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
24451 Set_SPARK_Pragma
(Body_Id
, N
);
24452 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24453 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
24454 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
24456 -- For protected and task bodies, verify the legality against:
24457 -- * The mode of the context
24458 -- * The mode of the private part
24462 (Nkind
(Decl
) in N_Protected_Body | N_Task_Body
);
24464 Check_Pragma_Conformance
24465 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
24467 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
24470 Set_SPARK_Pragma
(Body_Id
, N
);
24471 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
24475 --------------------------
24476 -- Process_Overloadable --
24477 --------------------------
24479 procedure Process_Overloadable
(Decl
: Node_Id
) is
24480 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24481 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
24484 Check_Library_Level_Entity
(Spec_Id
);
24486 -- Verify the legality against:
24487 -- * The mode of the context
24489 Check_Pragma_Conformance
24490 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
24492 Entity_Pragma
=> Empty
);
24494 Set_SPARK_Pragma
(Spec_Id
, N
);
24495 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
24497 -- When the pragma applies to the anonymous object created for
24498 -- a single task type, decorate the type as well. This scenario
24499 -- arises when the single task type lacks a task definition,
24500 -- therefore there is no issue with respect to a potential
24501 -- pragma SPARK_Mode in the private part.
24503 -- task type Anon_Task_Typ;
24504 -- Obj : Anon_Task_Typ;
24505 -- pragma SPARK_Mode ...;
24507 if Is_Single_Task_Object
(Spec_Id
) then
24508 Set_SPARK_Pragma
(Spec_Typ
, N
);
24509 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
24510 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
24511 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
24513 end Process_Overloadable
;
24515 --------------------------
24516 -- Process_Private_Part --
24517 --------------------------
24519 procedure Process_Private_Part
(Decl
: Node_Id
) is
24520 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24523 Check_Library_Level_Entity
(Spec_Id
);
24525 -- Verify the legality against:
24526 -- * The mode of the visible declarations
24528 Check_Pragma_Conformance
24529 (Context_Pragma
=> Empty
,
24531 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
24534 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
24535 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
24536 end Process_Private_Part
;
24538 ----------------------------
24539 -- Process_Statement_Part --
24540 ----------------------------
24542 procedure Process_Statement_Part
(Decl
: Node_Id
) is
24543 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24546 Check_Library_Level_Entity
(Body_Id
);
24548 -- Verify the legality against:
24549 -- * The mode of the body declarations
24551 Check_Pragma_Conformance
24552 (Context_Pragma
=> Empty
,
24554 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
24557 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
24558 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
24559 end Process_Statement_Part
;
24561 --------------------------
24562 -- Process_Visible_Part --
24563 --------------------------
24565 procedure Process_Visible_Part
(Decl
: Node_Id
) is
24566 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
24567 Obj_Id
: Entity_Id
;
24570 Check_Library_Level_Entity
(Spec_Id
);
24572 -- Verify the legality against:
24573 -- * The mode of the context
24575 Check_Pragma_Conformance
24576 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
24578 Entity_Pragma
=> Empty
);
24580 -- A task unit declared without a definition does not set the
24581 -- SPARK_Mode of the context because the task does not have any
24582 -- entries that could inherit the mode.
24584 if Nkind
(Decl
) not in
24585 N_Single_Task_Declaration | N_Task_Type_Declaration
24590 Set_SPARK_Pragma
(Spec_Id
, N
);
24591 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
24592 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
24593 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
24595 -- When the pragma applies to a single protected or task type,
24596 -- decorate the corresponding anonymous object as well.
24598 -- protected Anon_Prot_Typ is
24599 -- pragma SPARK_Mode ...;
24601 -- end Anon_Prot_Typ;
24603 -- Obj : Anon_Prot_Typ;
24605 if Is_Single_Concurrent_Type
(Spec_Id
) then
24606 Obj_Id
:= Anonymous_Object
(Spec_Id
);
24608 Set_SPARK_Pragma
(Obj_Id
, N
);
24609 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
24611 end Process_Visible_Part
;
24613 -----------------------
24614 -- Set_SPARK_Context --
24615 -----------------------
24617 procedure Set_SPARK_Context
is
24619 SPARK_Mode
:= Mode_Id
;
24620 SPARK_Mode_Pragma
:= N
;
24621 end Set_SPARK_Context
;
24629 -- Start of processing for Do_SPARK_Mode
24633 Check_No_Identifiers
;
24634 Check_At_Most_N_Arguments
(1);
24636 -- Check the legality of the mode (no argument = ON)
24638 if Arg_Count
= 1 then
24639 Check_Arg_Is_One_Of
(Arg1
, Name_Auto
, Name_On
, Name_Off
);
24640 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
24645 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
24646 Context
:= Parent
(N
);
24648 -- When a SPARK_Mode pragma appears inside an instantiation whose
24649 -- enclosing context has SPARK_Mode set to "off", the pragma has
24650 -- no semantic effect.
24652 if Ignore_SPARK_Mode_Pragmas_In_Instance
24653 and then Mode_Id
/= Off
24655 Rewrite
(N
, Make_Null_Statement
(Loc
));
24660 -- The pragma appears in a configuration file
24662 if No
(Context
) then
24663 Check_Valid_Configuration_Pragma
;
24665 if Present
(SPARK_Mode_Pragma
) then
24668 Prev
=> SPARK_Mode_Pragma
);
24674 -- The pragma acts as a configuration pragma in a compilation unit
24676 -- pragma SPARK_Mode ...;
24677 -- package Pack is ...;
24679 elsif Nkind
(Context
) = N_Compilation_Unit
24680 and then List_Containing
(N
) = Context_Items
(Context
)
24682 Check_Valid_Configuration_Pragma
;
24685 -- Otherwise the placement of the pragma within the tree dictates
24686 -- its associated construct. Inspect the declarative list where
24687 -- the pragma resides to find a potential construct.
24690 -- An explicit mode of Auto is only allowed as a configuration
24691 -- pragma. Escape "pragma" to avoid replacement with "aspect".
24693 if Mode_Id
= None
then
24695 ("only configuration 'p'r'a'g'm'a% can have value &",
24700 while Present
(Stmt
) loop
24702 -- Skip prior pragmas, but check for duplicates. Note that
24703 -- this also takes care of pragmas generated for aspects.
24705 if Nkind
(Stmt
) = N_Pragma
then
24706 if Pragma_Name
(Stmt
) = Pname
then
24713 -- The pragma applies to an expression function that has
24714 -- already been rewritten into a subprogram declaration.
24716 -- function Expr_Func return ... is (...);
24717 -- pragma SPARK_Mode ...;
24719 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
24720 and then Nkind
(Original_Node
(Stmt
)) =
24721 N_Expression_Function
24723 Process_Overloadable
(Stmt
);
24726 -- The pragma applies to the anonymous object created for a
24727 -- single concurrent type.
24729 -- protected type Anon_Prot_Typ ...;
24730 -- Obj : Anon_Prot_Typ;
24731 -- pragma SPARK_Mode ...;
24733 elsif Nkind
(Stmt
) = N_Object_Declaration
24734 and then Is_Single_Concurrent_Object
24735 (Defining_Entity
(Stmt
))
24737 Process_Overloadable
(Stmt
);
24740 -- Skip internally generated code
24742 elsif not Comes_From_Source
(Stmt
) then
24745 -- The pragma applies to an entry or [generic] subprogram
24749 -- pragma SPARK_Mode ...;
24752 -- procedure Proc ...;
24753 -- pragma SPARK_Mode ...;
24755 elsif Nkind
(Stmt
) in N_Generic_Subprogram_Declaration
24756 | N_Subprogram_Declaration
24757 or else (Nkind
(Stmt
) = N_Entry_Declaration
24758 and then Is_Protected_Type
24759 (Scope
(Defining_Entity
(Stmt
))))
24761 Process_Overloadable
(Stmt
);
24764 -- Otherwise the pragma does not apply to a legal construct
24765 -- or it does not appear at the top of a declarative or a
24766 -- statement list. Issue an error and stop the analysis.
24775 -- The pragma applies to a package or a subprogram that acts as
24776 -- a compilation unit.
24778 -- procedure Proc ...;
24779 -- pragma SPARK_Mode ...;
24781 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
24782 Context
:= Unit
(Parent
(Context
));
24785 -- The pragma appears at the top of entry, package, protected
24786 -- unit, subprogram or task unit body declarations.
24788 -- entry Ent when ... is
24789 -- pragma SPARK_Mode ...;
24791 -- package body Pack is
24792 -- pragma SPARK_Mode ...;
24794 -- procedure Proc ... is
24795 -- pragma SPARK_Mode;
24797 -- protected body Prot is
24798 -- pragma SPARK_Mode ...;
24800 if Nkind
(Context
) in N_Entry_Body
24803 | N_Subprogram_Body
24806 Process_Body
(Context
);
24808 -- The pragma appears at the top of the visible or private
24809 -- declaration of a package spec, protected or task unit.
24812 -- pragma SPARK_Mode ...;
24814 -- pragma SPARK_Mode ...;
24816 -- protected [type] Prot is
24817 -- pragma SPARK_Mode ...;
24819 -- pragma SPARK_Mode ...;
24821 elsif Nkind
(Context
) in N_Package_Specification
24822 | N_Protected_Definition
24823 | N_Task_Definition
24825 if List_Containing
(N
) = Visible_Declarations
(Context
) then
24826 Process_Visible_Part
(Parent
(Context
));
24828 Process_Private_Part
(Parent
(Context
));
24831 -- The pragma appears at the top of package body statements
24833 -- package body Pack is
24835 -- pragma SPARK_Mode;
24837 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
24838 and then Nkind
(Parent
(Context
)) = N_Package_Body
24840 Process_Statement_Part
(Parent
(Context
));
24842 -- The pragma appeared as an aspect of a [generic] subprogram
24843 -- declaration that acts as a compilation unit.
24846 -- procedure Proc ...;
24847 -- pragma SPARK_Mode ...;
24849 elsif Nkind
(Context
) in N_Generic_Subprogram_Declaration
24850 | N_Subprogram_Declaration
24852 Process_Overloadable
(Context
);
24854 -- The pragma does not apply to a legal construct, issue error
24862 --------------------------------
24863 -- Static_Elaboration_Desired --
24864 --------------------------------
24866 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
24868 when Pragma_Static_Elaboration_Desired
=>
24870 Check_At_Most_N_Arguments
(1);
24872 if Is_Compilation_Unit
(Current_Scope
)
24873 and then Ekind
(Current_Scope
) = E_Package
24875 Set_Static_Elaboration_Desired
(Current_Scope
, True);
24877 Error_Pragma
("pragma% must apply to a library-level package");
24884 -- pragma Storage_Size (EXPRESSION);
24886 when Pragma_Storage_Size
=> Storage_Size
: declare
24887 P
: constant Node_Id
:= Parent
(N
);
24891 Check_No_Identifiers
;
24892 Check_Arg_Count
(1);
24894 -- The expression must be analyzed in the special manner described
24895 -- in "Handling of Default Expressions" in sem.ads.
24897 Arg
:= Get_Pragma_Arg
(Arg1
);
24898 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
24900 if not Is_OK_Static_Expression
(Arg
) then
24901 Check_Restriction
(Static_Storage_Size
, Arg
);
24904 if Nkind
(P
) /= N_Task_Definition
then
24908 if Has_Storage_Size_Pragma
(P
) then
24909 Error_Pragma
("duplicate pragma% not allowed");
24911 Set_Has_Storage_Size_Pragma
(P
, True);
24914 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
24922 -- pragma Storage_Unit (NUMERIC_LITERAL);
24924 -- Only permitted argument is System'Storage_Unit value
24926 when Pragma_Storage_Unit
=>
24927 Check_No_Identifiers
;
24928 Check_Arg_Count
(1);
24929 Check_Arg_Is_Integer_Literal
(Arg1
);
24931 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
24932 UI_From_Int
(Ttypes
.System_Storage_Unit
)
24934 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
24936 ("the only allowed argument for pragma% is ^", Arg1
);
24939 --------------------
24940 -- Stream_Convert --
24941 --------------------
24943 -- pragma Stream_Convert (
24944 -- [Entity =>] type_LOCAL_NAME,
24945 -- [Read =>] function_NAME,
24946 -- [Write =>] function NAME);
24948 when Pragma_Stream_Convert
=> Stream_Convert
: declare
24949 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
24950 -- Check that the given argument is the name of a local function
24951 -- of one argument that is not overloaded earlier in the current
24952 -- local scope. A check is also made that the argument is a
24953 -- function with one parameter.
24955 --------------------------------------
24956 -- Check_OK_Stream_Convert_Function --
24957 --------------------------------------
24959 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
24963 Check_Arg_Is_Local_Name
(Arg
);
24964 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
24966 if Has_Homonym
(Ent
) then
24968 ("argument for pragma% may not be overloaded", Arg
);
24971 if Ekind
(Ent
) /= E_Function
24972 or else No
(First_Formal
(Ent
))
24973 or else Present
(Next_Formal
(First_Formal
(Ent
)))
24976 ("argument for pragma% must be function of one argument",
24978 elsif Is_Abstract_Subprogram
(Ent
) then
24980 ("argument for pragma% cannot be abstract", Arg
);
24982 end Check_OK_Stream_Convert_Function
;
24984 -- Start of processing for Stream_Convert
24988 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
24989 Check_Arg_Count
(3);
24990 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24991 Check_Optional_Identifier
(Arg2
, Name_Read
);
24992 Check_Optional_Identifier
(Arg3
, Name_Write
);
24993 Check_Arg_Is_Local_Name
(Arg1
);
24994 Check_OK_Stream_Convert_Function
(Arg2
);
24995 Check_OK_Stream_Convert_Function
(Arg3
);
24998 Typ
: constant Entity_Id
:=
24999 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
25000 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
25001 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
25004 Check_First_Subtype
(Arg1
);
25006 -- Check for too early or too late. Note that we don't enforce
25007 -- the rule about primitive operations in this case, since, as
25008 -- is the case for explicit stream attributes themselves, these
25009 -- restrictions are not appropriate. Note that the chaining of
25010 -- the pragma by Rep_Item_Too_Late is actually the critical
25011 -- processing done for this pragma.
25013 if Rep_Item_Too_Early
(Typ
, N
)
25015 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
25020 -- Return if previous error
25022 if Etype
(Typ
) = Any_Type
25024 Etype
(Read
) = Any_Type
25026 Etype
(Write
) = Any_Type
25033 if Underlying_Type
(Etype
(Read
)) /= Typ
then
25035 ("incorrect return type for function&", Arg2
);
25038 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
25040 ("incorrect parameter type for function&", Arg3
);
25043 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
25044 Underlying_Type
(Etype
(Write
))
25047 ("result type of & does not match Read parameter type",
25051 end Stream_Convert
;
25057 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25059 -- This is processed by the parser since some of the style checks
25060 -- take place during source scanning and parsing. This means that
25061 -- we don't need to issue error messages here.
25063 when Pragma_Style_Checks
=> Style_Checks
: declare
25064 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25070 Check_No_Identifiers
;
25072 -- Two argument form
25074 if Arg_Count
= 2 then
25075 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
25082 E_Id
:= Get_Pragma_Arg
(Arg2
);
25085 if not Is_Entity_Name
(E_Id
) then
25087 ("second argument of pragma% must be entity name",
25091 E
:= Entity
(E_Id
);
25093 if not Ignore_Style_Checks_Pragmas
then
25098 Set_Suppress_Style_Checks
25099 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
25100 exit when No
(Homonym
(E
));
25107 -- One argument form
25110 Check_Arg_Count
(1);
25112 if Ignore_Style_Checks_Pragmas
then
25116 if Nkind
(A
) = N_String_Literal
then
25120 Slen
: constant Natural := Natural (String_Length
(S
));
25121 Options
: String (1 .. Slen
);
25127 C
:= Get_String_Char
(S
, Pos
(J
));
25128 exit when not In_Character_Range
(C
);
25129 Options
(J
) := Get_Character
(C
);
25131 -- If at end of string, set options. As per discussion
25132 -- above, no need to check for errors, since we issued
25133 -- them in the parser.
25136 Set_Style_Check_Options
(Options
);
25145 elsif Nkind
(A
) = N_Identifier
then
25146 if Chars
(A
) = Name_All_Checks
then
25148 Set_GNAT_Style_Check_Options
;
25150 Set_Default_Style_Check_Options
;
25153 elsif Chars
(A
) = Name_On
then
25154 Style_Check
:= True;
25156 elsif Chars
(A
) = Name_Off
then
25157 Style_Check
:= False;
25163 ------------------------
25164 -- Subprogram_Variant --
25165 ------------------------
25167 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_LIST );
25169 -- SUBPROGRAM_VARIANT_LIST ::= STRUCTURAL_SUBPROGRAM_VARIANT_ITEM
25170 -- | NUMERIC_SUBPROGRAM_VARIANT_ITEMS
25171 -- NUMERIC_SUBPROGRAM_VARIANT_ITEMS ::=
25172 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM
25173 -- {, NUMERIC_SUBPROGRAM_VARIANT_ITEM}
25174 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM ::= CHANGE_DIRECTION => EXPRESSION
25175 -- STRUCTURAL_SUBPROGRAM_VARIANT_ITEM ::= Structural => EXPRESSION
25176 -- CHANGE_DIRECTION ::= Increases | Decreases
25178 -- Characteristics:
25180 -- * Analysis - The annotation undergoes initial checks to verify
25181 -- the legal placement and context. Secondary checks preanalyze the
25184 -- Analyze_Subprogram_Variant_In_Decl_Part
25186 -- * Expansion - The annotation is expanded during the expansion of
25187 -- the related subprogram [body] contract as performed in:
25189 -- Expand_Subprogram_Contract
25191 -- * Template - The annotation utilizes the generic template of the
25192 -- related subprogram [body] when it is:
25194 -- aspect on subprogram declaration
25195 -- aspect on stand-alone subprogram body
25196 -- pragma on stand-alone subprogram body
25198 -- The annotation must prepare its own template when it is:
25200 -- pragma on subprogram declaration
25202 -- * Globals - Capture of global references must occur after full
25205 -- * Instance - The annotation is instantiated automatically when
25206 -- the related generic subprogram [body] is instantiated except for
25207 -- the "pragma on subprogram declaration" case. In that scenario
25208 -- the annotation must instantiate itself.
25210 when Pragma_Subprogram_Variant
=> Subprogram_Variant
: declare
25211 Spec_Id
: Entity_Id
;
25212 Subp_Decl
: Node_Id
;
25213 Subp_Spec
: Node_Id
;
25217 Check_No_Identifiers
;
25218 Check_Arg_Count
(1);
25220 -- Ensure the proper placement of the pragma. Subprogram_Variant
25221 -- must be associated with a subprogram declaration or a body that
25225 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25227 -- Generic subprogram
25229 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25232 -- Body acts as spec
25234 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25235 and then No
(Corresponding_Spec
(Subp_Decl
))
25239 -- Body stub acts as spec
25241 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25242 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25248 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25249 Subp_Spec
:= Specification
(Subp_Decl
);
25251 -- Pragma Subprogram_Variant is forbidden on null procedures,
25252 -- as this may lead to potential ambiguities in behavior when
25253 -- interface null procedures are involved. Also, it just
25254 -- wouldn't make sense, because null procedure is not
25257 if Nkind
(Subp_Spec
) = N_Procedure_Specification
25258 and then Null_Present
(Subp_Spec
)
25260 Error_Msg_N
(Fix_Error
25261 ("pragma % cannot apply to null procedure"), N
);
25269 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
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
, Spec_Id
);
25275 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
25277 -- Chain the pragma on the contract for further processing by
25278 -- Analyze_Subprogram_Variant_In_Decl_Part.
25280 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
25282 -- Fully analyze the pragma when it appears inside a subprogram
25283 -- body because it cannot benefit from forward references.
25285 if Nkind
(Subp_Decl
) in N_Subprogram_Body
25286 | N_Subprogram_Body_Stub
25288 -- The legality checks of pragma Subprogram_Variant are
25289 -- affected by the SPARK mode in effect and the volatility
25290 -- of the context. Analyze all pragmas in a specific order.
25292 Analyze_If_Present
(Pragma_SPARK_Mode
);
25293 Analyze_If_Present
(Pragma_Volatile_Function
);
25294 Analyze_Subprogram_Variant_In_Decl_Part
(N
);
25296 end Subprogram_Variant
;
25302 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
25304 when Pragma_Subtitle
=>
25306 Check_Arg_Count
(1);
25307 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
25308 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
25315 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
25317 when Pragma_Suppress
=>
25318 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
25324 -- pragma Suppress_All;
25326 -- The only check made here is that the pragma has no arguments.
25327 -- There are no placement rules, and the processing required (setting
25328 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
25329 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
25330 -- then creates and inserts a pragma Suppress (All_Checks).
25332 when Pragma_Suppress_All
=>
25334 Check_Arg_Count
(0);
25336 -------------------------
25337 -- Suppress_Debug_Info --
25338 -------------------------
25340 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
25342 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
25343 Nam_Id
: Entity_Id
;
25347 Check_Arg_Count
(1);
25348 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25349 Check_Arg_Is_Local_Name
(Arg1
);
25351 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
25353 -- A pragma that applies to a Ghost entity becomes Ghost for the
25354 -- purposes of legality checks and removal of ignored Ghost code.
25356 Mark_Ghost_Pragma
(N
, Nam_Id
);
25357 Set_Debug_Info_Off
(Nam_Id
);
25358 end Suppress_Debug_Info
;
25360 ----------------------------------
25361 -- Suppress_Exception_Locations --
25362 ----------------------------------
25364 -- pragma Suppress_Exception_Locations;
25366 when Pragma_Suppress_Exception_Locations
=>
25368 Check_Arg_Count
(0);
25369 Check_Valid_Configuration_Pragma
;
25370 Exception_Locations_Suppressed
:= True;
25372 -----------------------------
25373 -- Suppress_Initialization --
25374 -----------------------------
25376 -- pragma Suppress_Initialization ([Entity =>] type_Name);
25378 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
25384 Check_Arg_Count
(1);
25385 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25386 Check_Arg_Is_Local_Name
(Arg1
);
25388 E_Id
:= Get_Pragma_Arg
(Arg1
);
25390 if Etype
(E_Id
) = Any_Type
then
25394 E
:= Entity
(E_Id
);
25396 -- A pragma that applies to a Ghost entity becomes Ghost for the
25397 -- purposes of legality checks and removal of ignored Ghost code.
25399 Mark_Ghost_Pragma
(N
, E
);
25401 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
25403 ("pragma% requires variable, type or subtype", Arg1
);
25406 if Rep_Item_Too_Early
(E
, N
)
25408 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
25413 -- For incomplete/private type, set flag on full view
25415 if Is_Incomplete_Or_Private_Type
(E
) then
25416 if No
(Full_View
(Base_Type
(E
))) then
25418 ("argument of pragma% cannot be an incomplete type", Arg1
);
25420 Set_Suppress_Initialization
(Full_View
(E
));
25423 -- For first subtype, set flag on base type
25425 elsif Is_First_Subtype
(E
) then
25426 Set_Suppress_Initialization
(Base_Type
(E
));
25428 -- For other than first subtype, set flag on subtype or variable
25431 Set_Suppress_Initialization
(E
);
25439 -- pragma System_Name (DIRECT_NAME);
25441 -- Syntax check: one argument, which must be the identifier GNAT or
25442 -- the identifier GCC, no other identifiers are acceptable.
25444 when Pragma_System_Name
=>
25446 Check_No_Identifiers
;
25447 Check_Arg_Count
(1);
25448 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
25450 -----------------------------
25451 -- Task_Dispatching_Policy --
25452 -----------------------------
25454 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
25456 when Pragma_Task_Dispatching_Policy
=> declare
25460 Check_Ada_83_Warning
;
25461 Check_Arg_Count
(1);
25462 Check_No_Identifiers
;
25463 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
25464 Check_Valid_Configuration_Pragma
;
25465 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
25466 DP
:= Fold_Upper
(Name_Buffer
(1));
25468 if Task_Dispatching_Policy
/= ' '
25469 and then Task_Dispatching_Policy
/= DP
25471 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
25473 ("task dispatching policy incompatible with policy#");
25475 -- Set new policy, but always preserve System_Location since we
25476 -- like the error message with the run time name.
25479 Task_Dispatching_Policy
:= DP
;
25481 if Task_Dispatching_Policy_Sloc
/= System_Location
then
25482 Task_Dispatching_Policy_Sloc
:= Loc
;
25491 -- pragma Task_Info (EXPRESSION);
25493 when Pragma_Task_Info
=> Task_Info
: declare
25494 P
: constant Node_Id
:= Parent
(N
);
25500 if Warn_On_Obsolescent_Feature
then
25502 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
25503 & "instead?j?", N
);
25506 if Nkind
(P
) /= N_Task_Definition
then
25507 Error_Pragma
("pragma% must appear in task definition");
25510 Check_No_Identifiers
;
25511 Check_Arg_Count
(1);
25513 Analyze_And_Resolve
25514 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
25516 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
25520 Ent
:= Defining_Identifier
(Parent
(P
));
25522 -- Check duplicate pragma before we chain the pragma in the Rep
25523 -- Item chain of Ent.
25526 (Ent
, Name_Task_Info
, Check_Parents
=> False)
25528 Error_Pragma
("duplicate pragma% not allowed");
25531 Record_Rep_Item
(Ent
, N
);
25538 -- pragma Task_Name (string_EXPRESSION);
25540 when Pragma_Task_Name
=> Task_Name
: declare
25541 P
: constant Node_Id
:= Parent
(N
);
25546 Check_No_Identifiers
;
25547 Check_Arg_Count
(1);
25549 Arg
:= Get_Pragma_Arg
(Arg1
);
25551 -- The expression is used in the call to Create_Task, and must be
25552 -- expanded there, not in the context of the current spec. It must
25553 -- however be analyzed to capture global references, in case it
25554 -- appears in a generic context.
25556 Preanalyze_And_Resolve
(Arg
, Standard_String
);
25558 if Nkind
(P
) /= N_Task_Definition
then
25562 Ent
:= Defining_Identifier
(Parent
(P
));
25564 -- Check duplicate pragma before we chain the pragma in the Rep
25565 -- Item chain of Ent.
25568 (Ent
, Name_Task_Name
, Check_Parents
=> False)
25570 Error_Pragma
("duplicate pragma% not allowed");
25573 Record_Rep_Item
(Ent
, N
);
25580 -- pragma Task_Storage (
25581 -- [Task_Type =>] LOCAL_NAME,
25582 -- [Top_Guard =>] static_integer_EXPRESSION);
25584 when Pragma_Task_Storage
=> Task_Storage
: declare
25585 Args
: Args_List
(1 .. 2);
25586 Names
: constant Name_List
(1 .. 2) := (
25590 Task_Type
: Node_Id
renames Args
(1);
25591 Top_Guard
: Node_Id
renames Args
(2);
25597 Gather_Associations
(Names
, Args
);
25599 if No
(Task_Type
) then
25601 ("missing task_type argument for pragma%");
25604 Check_Arg_Is_Local_Name
(Task_Type
);
25606 Ent
:= Entity
(Task_Type
);
25608 if not Is_Task_Type
(Ent
) then
25610 ("argument for pragma% must be task type", Task_Type
);
25613 if No
(Top_Guard
) then
25615 ("pragma% takes two arguments", Task_Type
);
25617 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
25620 Check_First_Subtype
(Task_Type
);
25622 if Rep_Item_Too_Late
(Ent
, N
) then
25631 -- pragma Test_Case
25632 -- ([Name =>] Static_String_EXPRESSION
25633 -- ,[Mode =>] MODE_TYPE
25634 -- [, Requires => Boolean_EXPRESSION]
25635 -- [, Ensures => Boolean_EXPRESSION]);
25637 -- MODE_TYPE ::= Nominal | Robustness
25639 -- Characteristics:
25641 -- * Analysis - The annotation undergoes initial checks to verify
25642 -- the legal placement and context. Secondary checks preanalyze the
25645 -- Analyze_Test_Case_In_Decl_Part
25647 -- * Expansion - None.
25649 -- * Template - The annotation utilizes the generic template of the
25650 -- related subprogram when it is:
25652 -- aspect on subprogram declaration
25654 -- The annotation must prepare its own template when it is:
25656 -- pragma on subprogram declaration
25658 -- * Globals - Capture of global references must occur after full
25661 -- * Instance - The annotation is instantiated automatically when
25662 -- the related generic subprogram is instantiated except for the
25663 -- "pragma on subprogram declaration" case. In that scenario the
25664 -- annotation must instantiate itself.
25666 when Pragma_Test_Case
=> Test_Case
: declare
25667 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
25668 -- Ensure that the contract of subprogram Subp_Id does not contain
25669 -- another Test_Case pragma with the same Name as the current one.
25671 -------------------------
25672 -- Check_Distinct_Name --
25673 -------------------------
25675 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
25676 Items
: constant Node_Id
:= Contract
(Subp_Id
);
25677 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
25681 -- Inspect all Test_Case pragma of the related subprogram
25682 -- looking for one with a duplicate "Name" argument.
25684 if Present
(Items
) then
25685 Prag
:= Contract_Test_Cases
(Items
);
25686 while Present
(Prag
) loop
25687 if Pragma_Name
(Prag
) = Name_Test_Case
25689 and then String_Equal
25690 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
25692 Error_Msg_Sloc
:= Sloc
(Prag
);
25693 Error_Pragma
("name for pragma % is already used #");
25696 Prag
:= Next_Pragma
(Prag
);
25699 end Check_Distinct_Name
;
25703 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
25706 Subp_Decl
: Node_Id
;
25707 Subp_Id
: Entity_Id
;
25709 -- Start of processing for Test_Case
25713 Check_At_Least_N_Arguments
(2);
25714 Check_At_Most_N_Arguments
(4);
25716 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
25720 Check_Optional_Identifier
(Arg1
, Name_Name
);
25721 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
25725 Check_Optional_Identifier
(Arg2
, Name_Mode
);
25726 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
25728 -- Arguments "Requires" and "Ensures"
25730 if Present
(Arg3
) then
25731 if Present
(Arg4
) then
25732 Check_Identifier
(Arg3
, Name_Requires
);
25733 Check_Identifier
(Arg4
, Name_Ensures
);
25735 Check_Identifier_Is_One_Of
25736 (Arg3
, Name_Requires
, Name_Ensures
);
25740 -- Pragma Test_Case must be associated with a subprogram declared
25741 -- in a library-level package. First determine whether the current
25742 -- compilation unit is a legal context.
25744 if Nkind
(Pack_Decl
) in N_Package_Declaration
25745 | N_Generic_Package_Declaration
25749 -- Otherwise the placement is illegal
25753 ("pragma % must be specified within a package declaration");
25756 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
25758 -- Find the enclosing context
25760 Context
:= Parent
(Subp_Decl
);
25762 if Present
(Context
) then
25763 Context
:= Parent
(Context
);
25766 -- Verify the placement of the pragma
25768 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
25770 ("pragma % cannot be applied to abstract subprogram");
25772 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
25773 Error_Pragma
("pragma % cannot be applied to entry");
25775 -- The context is a [generic] subprogram declared at the top level
25776 -- of the [generic] package unit.
25778 elsif Nkind
(Subp_Decl
) in N_Generic_Subprogram_Declaration
25779 | N_Subprogram_Declaration
25780 and then Present
(Context
)
25781 and then Nkind
(Context
) in N_Generic_Package_Declaration
25782 | N_Package_Declaration
25786 -- Otherwise the placement is illegal
25790 ("pragma % must be applied to a library-level subprogram "
25794 Subp_Id
:= Defining_Entity
(Subp_Decl
);
25796 -- A pragma that applies to a Ghost entity becomes Ghost for the
25797 -- purposes of legality checks and removal of ignored Ghost code.
25799 Mark_Ghost_Pragma
(N
, Subp_Id
);
25801 -- Chain the pragma on the contract for further processing by
25802 -- Analyze_Test_Case_In_Decl_Part.
25804 Add_Contract_Item
(N
, Subp_Id
);
25806 -- Preanalyze the original aspect argument "Name" for a generic
25807 -- subprogram to properly capture global references.
25809 if Is_Generic_Subprogram
(Subp_Id
) then
25810 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
25812 if Present
(Asp_Arg
) then
25814 -- The argument appears with an identifier in association
25817 if Nkind
(Asp_Arg
) = N_Component_Association
then
25818 Asp_Arg
:= Expression
(Asp_Arg
);
25821 Check_Expr_Is_OK_Static_Expression
25822 (Asp_Arg
, Standard_String
);
25826 -- Ensure that the all Test_Case pragmas of the related subprogram
25827 -- have distinct names.
25829 Check_Distinct_Name
(Subp_Id
);
25831 -- Fully analyze the pragma when it appears inside an entry
25832 -- or subprogram body because it cannot benefit from forward
25835 if Nkind
(Subp_Decl
) in N_Entry_Body
25836 | N_Subprogram_Body
25837 | N_Subprogram_Body_Stub
25839 -- The legality checks of pragma Test_Case are affected by the
25840 -- SPARK mode in effect and the volatility of the context.
25841 -- Analyze all pragmas in a specific order.
25843 Analyze_If_Present
(Pragma_SPARK_Mode
);
25844 Analyze_If_Present
(Pragma_Volatile_Function
);
25845 Analyze_Test_Case_In_Decl_Part
(N
);
25849 --------------------------
25850 -- Thread_Local_Storage --
25851 --------------------------
25853 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
25855 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
25861 Check_Arg_Count
(1);
25862 Check_Optional_Identifier
(Arg1
, Name_Entity
);
25863 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
25865 Id
:= Get_Pragma_Arg
(Arg1
);
25867 if not Is_Entity_Name
(Id
)
25868 or else Ekind
(Entity
(Id
)) /= E_Variable
25870 Error_Pragma_Arg
("local variable name required", Arg1
);
25875 -- A pragma that applies to a Ghost entity becomes Ghost for the
25876 -- purposes of legality checks and removal of ignored Ghost code.
25878 Mark_Ghost_Pragma
(N
, E
);
25880 if Rep_Item_Too_Early
(E
, N
)
25882 Rep_Item_Too_Late
(E
, N
)
25887 Set_Has_Pragma_Thread_Local_Storage
(E
);
25888 Set_Has_Gigi_Rep_Item
(E
);
25889 end Thread_Local_Storage
;
25895 -- pragma Time_Slice (static_duration_EXPRESSION);
25897 when Pragma_Time_Slice
=> Time_Slice
: declare
25903 Check_Arg_Count
(1);
25904 Check_No_Identifiers
;
25905 Check_In_Main_Program
;
25906 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
25908 if not Error_Posted
(Arg1
) then
25910 while Present
(Nod
) loop
25911 if Nkind
(Nod
) = N_Pragma
25912 and then Pragma_Name
(Nod
) = Name_Time_Slice
25914 Error_Msg_Name_1
:= Pname
;
25915 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
25922 -- Process only if in main unit
25924 if Get_Source_Unit
(Loc
) = Main_Unit
then
25925 Opt
.Time_Slice_Set
:= True;
25926 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
25928 if Val
<= Ureal_0
then
25929 Opt
.Time_Slice_Value
:= 0;
25931 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
25932 Opt
.Time_Slice_Value
:= 1_000_000_000
;
25935 Opt
.Time_Slice_Value
:=
25936 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
25945 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
25947 -- TITLING_OPTION ::=
25948 -- [Title =>] STRING_LITERAL
25949 -- | [Subtitle =>] STRING_LITERAL
25951 when Pragma_Title
=> Title
: declare
25952 Args
: Args_List
(1 .. 2);
25953 Names
: constant Name_List
(1 .. 2) := (
25959 Gather_Associations
(Names
, Args
);
25962 for J
in 1 .. 2 loop
25963 if Present
(Args
(J
)) then
25964 Check_Arg_Is_OK_Static_Expression
25965 (Args
(J
), Standard_String
);
25970 ----------------------------
25971 -- Type_Invariant[_Class] --
25972 ----------------------------
25974 -- pragma Type_Invariant[_Class]
25975 -- ([Entity =>] type_LOCAL_NAME,
25976 -- [Check =>] EXPRESSION);
25978 when Pragma_Type_Invariant
25979 | Pragma_Type_Invariant_Class
25981 Type_Invariant
: declare
25982 I_Pragma
: Node_Id
;
25985 Check_Arg_Count
(2);
25987 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
25988 -- setting Class_Present for the Type_Invariant_Class case.
25990 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
25991 I_Pragma
:= New_Copy
(N
);
25992 Set_Pragma_Identifier
25993 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
25994 Rewrite
(N
, I_Pragma
);
25995 Set_Analyzed
(N
, False);
25997 end Type_Invariant
;
25999 ---------------------
26000 -- Unchecked_Union --
26001 ---------------------
26003 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
26005 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
26006 Assoc
: constant Node_Id
:= Arg1
;
26007 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
26017 Check_No_Identifiers
;
26018 Check_Arg_Count
(1);
26019 Check_Arg_Is_Local_Name
(Arg1
);
26021 Find_Type
(Type_Id
);
26023 Typ
:= Entity
(Type_Id
);
26025 -- A pragma that applies to a Ghost entity becomes Ghost for the
26026 -- purposes of legality checks and removal of ignored Ghost code.
26028 Mark_Ghost_Pragma
(N
, Typ
);
26031 or else Rep_Item_Too_Early
(Typ
, N
)
26035 Typ
:= Underlying_Type
(Typ
);
26038 if Rep_Item_Too_Late
(Typ
, N
) then
26042 Check_First_Subtype
(Arg1
);
26044 -- Note remaining cases are references to a type in the current
26045 -- declarative part. If we find an error, we post the error on
26046 -- the relevant type declaration at an appropriate point.
26048 if not Is_Record_Type
(Typ
) then
26049 Error_Msg_N
("unchecked union must be record type", Typ
);
26052 elsif Is_Tagged_Type
(Typ
) then
26053 Error_Msg_N
("unchecked union must not be tagged", Typ
);
26056 elsif not Has_Discriminants
(Typ
) then
26058 ("unchecked union must have one discriminant", Typ
);
26061 -- Note: in previous versions of GNAT we used to check for limited
26062 -- types and give an error, but in fact the standard does allow
26063 -- Unchecked_Union on limited types, so this check was removed.
26065 -- Similarly, GNAT used to require that all discriminants have
26066 -- default values, but this is not mandated by the RM.
26068 -- Proceed with basic error checks completed
26071 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
26072 Clist
:= Component_List
(Tdef
);
26074 -- Check presence of component list and variant part
26076 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
26078 ("unchecked union must have variant part", Tdef
);
26082 -- Check components
26084 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
26085 while Present
(Comp
) loop
26086 Check_Component
(Comp
, Typ
);
26087 Next_Non_Pragma
(Comp
);
26090 -- Check variant part
26092 Vpart
:= Variant_Part
(Clist
);
26094 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
26095 while Present
(Variant
) loop
26096 Check_Variant
(Variant
, Typ
);
26097 Next_Non_Pragma
(Variant
);
26101 Set_Is_Unchecked_Union
(Typ
);
26102 Set_Convention
(Typ
, Convention_C
);
26103 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
26104 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
26105 end Unchecked_Union
;
26107 ----------------------------
26108 -- Unevaluated_Use_Of_Old --
26109 ----------------------------
26111 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
26113 when Pragma_Unevaluated_Use_Of_Old
=>
26115 Check_Arg_Count
(1);
26116 Check_No_Identifiers
;
26117 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
26119 -- Suppress/Unsuppress can appear as a configuration pragma, or in
26120 -- a declarative part or a package spec.
26122 if not Is_Configuration_Pragma
then
26123 Check_Is_In_Decl_Part_Or_Package_Spec
;
26126 -- Store proper setting of Uneval_Old
26128 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
26129 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
26131 ------------------------
26132 -- Unimplemented_Unit --
26133 ------------------------
26135 -- pragma Unimplemented_Unit;
26137 -- Note: this only gives an error if we are generating code, or if
26138 -- we are in a generic library unit (where the pragma appears in the
26139 -- body, not in the spec).
26141 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
26142 Cunitent
: constant Entity_Id
:=
26143 Cunit_Entity
(Get_Source_Unit
(Loc
));
26147 Check_Arg_Count
(0);
26149 if Operating_Mode
= Generate_Code
26150 or else Is_Generic_Unit
(Cunitent
)
26152 Get_Name_String
(Chars
(Cunitent
));
26153 Set_Casing
(Mixed_Case
);
26154 Write_Str
(Name_Buffer
(1 .. Name_Len
));
26155 Write_Str
(" is not supported in this configuration");
26157 raise Unrecoverable_Error
;
26159 end Unimplemented_Unit
;
26161 ------------------------
26162 -- Universal_Aliasing --
26163 ------------------------
26165 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
26167 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
26173 Check_Arg_Count
(1);
26174 Check_Optional_Identifier
(Arg2
, Name_Entity
);
26175 Check_Arg_Is_Local_Name
(Arg1
);
26176 E_Id
:= Get_Pragma_Arg
(Arg1
);
26178 if Etype
(E_Id
) = Any_Type
then
26182 E
:= Entity
(E_Id
);
26184 if not Is_Type
(E
) then
26185 Error_Pragma_Arg
("pragma% requires type", Arg1
);
26188 -- A pragma that applies to a Ghost entity becomes Ghost for the
26189 -- purposes of legality checks and removal of ignored Ghost code.
26191 Mark_Ghost_Pragma
(N
, E
);
26192 Set_Universal_Aliasing
(Base_Type
(E
));
26193 Record_Rep_Item
(E
, N
);
26194 end Universal_Alias
;
26200 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
26202 when Pragma_Unmodified
=>
26203 Analyze_Unmodified_Or_Unused
;
26209 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
26211 -- or when used in a context clause:
26213 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
26215 when Pragma_Unreferenced
=>
26216 Analyze_Unreferenced_Or_Unused
;
26218 --------------------------
26219 -- Unreferenced_Objects --
26220 --------------------------
26222 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
26224 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
26226 Arg_Expr
: Node_Id
;
26227 Arg_Id
: Entity_Id
;
26229 Ghost_Error_Posted
: Boolean := False;
26230 -- Flag set when an error concerning the illegal mix of Ghost and
26231 -- non-Ghost types is emitted.
26233 Ghost_Id
: Entity_Id
:= Empty
;
26234 -- The entity of the first Ghost type encountered while processing
26235 -- the arguments of the pragma.
26239 Check_At_Least_N_Arguments
(1);
26242 while Present
(Arg
) loop
26243 Check_No_Identifier
(Arg
);
26244 Check_Arg_Is_Local_Name
(Arg
);
26245 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
26247 if Is_Entity_Name
(Arg_Expr
) then
26248 Arg_Id
:= Entity
(Arg_Expr
);
26250 if Is_Type
(Arg_Id
) then
26251 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
26253 -- A pragma that applies to a Ghost entity becomes Ghost
26254 -- for the purposes of legality checks and removal of
26255 -- ignored Ghost code.
26257 Mark_Ghost_Pragma
(N
, Arg_Id
);
26259 -- Capture the entity of the first Ghost type being
26260 -- processed for error detection purposes.
26262 if Is_Ghost_Entity
(Arg_Id
) then
26263 if No
(Ghost_Id
) then
26264 Ghost_Id
:= Arg_Id
;
26267 -- Otherwise the type is non-Ghost. It is illegal to mix
26268 -- references to Ghost and non-Ghost entities
26271 elsif Present
(Ghost_Id
)
26272 and then not Ghost_Error_Posted
26274 Ghost_Error_Posted
:= True;
26276 Error_Msg_Name_1
:= Pname
;
26278 ("pragma % cannot mention ghost and non-ghost types",
26281 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
26282 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
26284 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
26285 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
26289 ("argument for pragma% must be type or subtype", Arg
);
26293 ("argument for pragma% must be type or subtype", Arg
);
26298 end Unreferenced_Objects
;
26300 ------------------------------
26301 -- Unreserve_All_Interrupts --
26302 ------------------------------
26304 -- pragma Unreserve_All_Interrupts;
26306 when Pragma_Unreserve_All_Interrupts
=>
26308 Check_Arg_Count
(0);
26310 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
26311 Unreserve_All_Interrupts
:= True;
26318 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
26320 when Pragma_Unsuppress
=>
26322 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
26328 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
26330 when Pragma_Unused
=>
26331 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
26332 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
26334 -------------------
26335 -- Use_VADS_Size --
26336 -------------------
26338 -- pragma Use_VADS_Size;
26340 when Pragma_Use_VADS_Size
=>
26342 Check_Arg_Count
(0);
26343 Check_Valid_Configuration_Pragma
;
26344 Use_VADS_Size
:= True;
26346 ----------------------------
26347 -- User_Aspect_Definition --
26348 ----------------------------
26350 -- pragma User_Aspect_Definition
26351 -- (Identifier, {, Identifier [(Identifier {, Identifier})]});
26353 when Pragma_User_Aspect_Definition
=>
26355 Check_Valid_Configuration_Pragma
;
26358 First
(Pragma_Argument_Associations
(N
));
26359 User_Aspect_Name
: constant Name_Id
:= Chars
(Expression
(Arg
));
26361 Aspect
: Aspect_Id
;
26363 if Get_Aspect_Id
(User_Aspect_Name
) /= No_Aspect
then
26365 ("User-defined aspect name for pragma% is the name " &
26366 "of an existing aspect", Arg
);
26369 Next
(Arg
); -- skip first argument, the name of the aspect
26371 while Present
(Arg
) loop
26372 Expr
:= Expression
(Arg
);
26373 case Nkind
(Expr
) is
26374 when N_Identifier
=>
26375 Aspect
:= Get_Aspect_Id
(Chars
(Expr
));
26376 if Aspect
in Boolean_Aspects
26377 and not Is_Representation_Aspect
(Aspect
)
26379 -- If we allowed representation aspects such as
26380 -- Pack here, then User_Aspect itself would need
26381 -- to be a representation aspect.
26384 elsif Aspect
= No_Aspect
and then
26385 Present
(User_Aspect_Support
.Registered_UAD_Pragma
26386 (User_Aspect_Name
))
26391 ("unparameterized argument for pragma% must be " &
26392 "either a Boolean-valued non-representation " &
26393 "aspect or user-defined", Arg
);
26395 when N_Indexed_Component
=>
26396 Aspect
:= Get_Aspect_Id
(Chars
(Prefix
(Expr
)));
26398 -- Aspect should be an aspect that takes
26399 -- identifier arguments that do not refer to
26400 -- declarations, but rather to undeclared entities
26401 -- such as GNATProve or No_Secondary_Stack for
26402 -- which the notion of visibility does not apply.
26405 when Aspect_Annotate
=>
26406 if List_Length
(Expressions
(Expr
)) /= 2 then
26408 ("Annotate argument for pragma% takes " &
26409 "two parameters", Arg
);
26412 when Aspect_Local_Restrictions
=>
26417 ("parameterized argument for pragma% must be " &
26418 "Annotate or Local_Restrictions aspect", Arg
);
26421 raise Program_Error
; -- parsing error
26427 Registered
: constant Node_Id
:=
26428 User_Aspect_Support
.Registered_UAD_Pragma
26429 (User_Aspect_Name
);
26431 -- Given two User_Aspect_Definition pragmas with
26432 -- matching names for the first argument, check that
26433 -- subsequent arguments also match; complain if they differ.
26434 procedure Check_UAD_Conformance
26435 (New_Pragma
, Old_Pragma
: Node_Id
);
26437 ---------------------------
26438 -- Check_UAD_Conformance --
26439 ---------------------------
26441 procedure Check_UAD_Conformance
26442 (New_Pragma
, Old_Pragma
: Node_Id
)
26444 Old_Arg
: Node_Id
:=
26445 First
(Pragma_Argument_Associations
(Old_Pragma
));
26446 New_Arg
: Node_Id
:=
26447 First
(Pragma_Argument_Associations
(New_Pragma
));
26448 OK
: Boolean := True;
26450 function Same_Chars
(Id1
, Id2
: Node_Id
) return Boolean
26451 is (Chars
(Id1
) = Chars
(Id2
));
26453 function Same_Identifier_List
(Id1
, Id2
: Node_Id
)
26455 is (if No
(Id1
) and No
(Id2
) then True
26456 elsif No
(Id1
) or No
(Id2
) then False
26457 else (Same_Chars
(Id1
, Id2
) and then
26458 Same_Identifier_List
(Next
(Id1
), Next
(Id2
))));
26460 -- We could skip the first argument pair since those
26461 -- are already known to match (or we wouldn't be
26462 -- calling this procedure).
26464 while Present
(Old_Arg
) or Present
(New_Arg
) loop
26465 if Present
(Old_Arg
) /= Present
(New_Arg
) then
26467 elsif Nkind
(Expression
(Old_Arg
)) /=
26468 Nkind
(Expression
(New_Arg
))
26472 case Nkind
(Expression
(Old_Arg
)) is
26473 when N_Identifier
=>
26474 OK
:= Same_Chars
(Expression
(Old_Arg
),
26475 Expression
(New_Arg
));
26477 when N_Indexed_Component
=>
26479 (Prefix
(Expression
(Old_Arg
)),
26480 Prefix
(Expression
(New_Arg
)))
26481 and then Same_Identifier_List
26482 (First
(Expressions
26483 (Expression
(Old_Arg
))),
26485 (Expression
(New_Arg
))));
26489 pragma Assert
(False);
26494 Error_Msg_Sloc
:= Sloc
(Old_Pragma
);
26496 ("Nonconforming definitions for user-defined " &
26497 "aspect #", New_Pragma
);
26504 end Check_UAD_Conformance
;
26506 if Present
(Registered
) then
26507 -- If we have already seen a UAD pragma with this name,
26508 -- then check that the two pragmas conform (which means
26509 -- that the new pragma is redundant and can be ignored).
26511 -- ??? We could also perform a similar bind-time check,
26512 -- since it is possible that an incompatible pair of
26513 -- UAD pragmas might not be detected by this check.
26514 -- This could arise if no unit's compilation closure
26515 -- includes both of the two. The major downside of
26516 -- failing to detect this case is possible confusion
26517 -- for human readers.
26519 Check_UAD_Conformance
(New_Pragma
=> N
,
26520 Old_Pragma
=> Registered
);
26522 User_Aspect_Support
.Register_UAD_Pragma
(N
);
26527 ---------------------
26528 -- Validity_Checks --
26529 ---------------------
26531 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
26533 when Pragma_Validity_Checks
=> Validity_Checks
: declare
26534 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
26540 Check_Arg_Count
(1);
26541 Check_No_Identifiers
;
26543 -- Pragma always active unless in CodePeer or GNATprove modes,
26544 -- which use a fixed configuration of validity checks.
26546 if not (CodePeer_Mode
or GNATprove_Mode
) then
26547 if Nkind
(A
) = N_String_Literal
then
26551 Slen
: constant Natural := Natural (String_Length
(S
));
26552 Options
: String (1 .. Slen
);
26556 -- Couldn't we use a for loop here over Options'Range???
26560 C
:= Get_String_Char
(S
, Pos
(J
));
26562 -- This is a weird test, it skips setting validity
26563 -- checks entirely if any element of S is out of
26564 -- range of Character, what is that about ???
26566 exit when not In_Character_Range
(C
);
26567 Options
(J
) := Get_Character
(C
);
26570 Set_Validity_Check_Options
(Options
);
26578 elsif Nkind
(A
) = N_Identifier
then
26579 if Chars
(A
) = Name_All_Checks
then
26580 Set_Validity_Check_Options
("a");
26581 elsif Chars
(A
) = Name_On
then
26582 Validity_Checks_On
:= True;
26583 elsif Chars
(A
) = Name_Off
then
26584 Validity_Checks_On
:= False;
26588 end Validity_Checks
;
26594 -- pragma Volatile (LOCAL_NAME);
26596 when Pragma_Volatile
=>
26597 Process_Atomic_Independent_Shared_Volatile
;
26599 -------------------------
26600 -- Volatile_Components --
26601 -------------------------
26603 -- pragma Volatile_Components (array_LOCAL_NAME);
26605 -- Volatile is handled by the same circuit as Atomic_Components
26607 --------------------------
26608 -- Volatile_Full_Access --
26609 --------------------------
26611 -- pragma Volatile_Full_Access (LOCAL_NAME);
26613 when Pragma_Volatile_Full_Access
=>
26615 Process_Atomic_Independent_Shared_Volatile
;
26617 -----------------------
26618 -- Volatile_Function --
26619 -----------------------
26621 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
26623 when Pragma_Volatile_Function
=> Volatile_Function
: declare
26624 Over_Id
: Entity_Id
;
26625 Spec_Id
: Entity_Id
;
26626 Subp_Decl
: Node_Id
;
26630 Check_No_Identifiers
;
26631 Check_At_Most_N_Arguments
(1);
26634 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
26636 -- Generic subprogram
26638 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
26641 -- Body acts as spec
26643 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
26644 and then No
(Corresponding_Spec
(Subp_Decl
))
26648 -- Body stub acts as spec
26650 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
26651 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
26657 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
26664 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26666 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
26670 -- A pragma that applies to a Ghost entity becomes Ghost for the
26671 -- purposes of legality checks and removal of ignored Ghost code.
26673 Mark_Ghost_Pragma
(N
, Spec_Id
);
26675 -- Chain the pragma on the contract for completeness
26677 Add_Contract_Item
(N
, Spec_Id
);
26679 -- The legality checks of pragma Volatile_Function are affected by
26680 -- the SPARK mode in effect. Analyze all pragmas in a specific
26683 Analyze_If_Present
(Pragma_SPARK_Mode
);
26685 -- A volatile function cannot override a non-volatile function
26686 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
26687 -- in New_Overloaded_Entity, however at that point the pragma has
26688 -- not been processed yet.
26690 Over_Id
:= Overridden_Operation
(Spec_Id
);
26692 if Present
(Over_Id
)
26693 and then not Is_Volatile_Function
(Over_Id
)
26696 ("incompatible volatile function values in effect", Spec_Id
);
26698 Error_Msg_Sloc
:= Sloc
(Over_Id
);
26700 ("\& declared # with Volatile_Function value False",
26703 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
26705 ("\overridden # with Volatile_Function value True",
26709 -- Analyze the Boolean expression (if any)
26711 if Present
(Arg1
) then
26712 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
26714 end Volatile_Function
;
26716 ----------------------
26717 -- Warning_As_Error --
26718 ----------------------
26720 -- pragma Warning_As_Error (static_string_EXPRESSION);
26722 when Pragma_Warning_As_Error
=>
26724 Check_Arg_Count
(1);
26725 Check_No_Identifiers
;
26726 Check_Valid_Configuration_Pragma
;
26728 if not Is_Static_String_Expression
(Arg1
) then
26730 ("argument of pragma% must be static string expression",
26733 -- OK static string expression
26736 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
26737 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
26738 new String'(Acquire_Warning_Match_String
26739 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
26746 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
26748 -- DETAILS ::= On | Off
26749 -- DETAILS ::= On | Off, local_NAME
26750 -- DETAILS ::= static_string_EXPRESSION
26751 -- DETAILS ::= On | Off, static_string_EXPRESSION
26753 -- TOOL_NAME ::= GNAT | GNATprove
26755 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
26757 -- Note: If the first argument matches an allowed tool name, it is
26758 -- always considered to be a tool name, even if there is a string
26759 -- variable of that name.
26761 -- Note if the second argument of DETAILS is a local_NAME then the
26762 -- second form is always understood. If the intention is to use
26763 -- the fourth form, then you can write NAME & "" to force the
26764 -- intepretation as a static_string_EXPRESSION.
26766 when Pragma_Warnings => Warnings : declare
26767 Reason : String_Id;
26771 Check_At_Least_N_Arguments (1);
26773 -- See if last argument is labeled Reason. If so, make sure we
26774 -- have a string literal or a concatenation of string literals,
26775 -- and acquire the REASON string. Then remove the REASON argument
26776 -- by decreasing Num_Args by one; Remaining processing looks only
26777 -- at first Num_Args arguments).
26780 Last_Arg : constant Node_Id :=
26781 Last (Pragma_Argument_Associations (N));
26784 if Nkind (Last_Arg) = N_Pragma_Argument_Association
26785 and then Chars (Last_Arg) = Name_Reason
26788 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
26789 Reason := End_String;
26790 Arg_Count := Arg_Count - 1;
26792 -- No REASON string, set null string as reason
26795 Reason := Null_String_Id;
26799 -- Now proceed with REASON taken care of and eliminated
26801 Check_No_Identifiers;
26803 -- If debug flag -gnatd.i is set, pragma is ignored
26805 if Debug_Flag_Dot_I then
26809 -- Process various forms of the pragma
26812 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
26813 Shifted_Args : List_Id;
26816 -- See if first argument is a tool name, currently either
26817 -- GNAT or GNATprove. If so, either ignore the pragma if the
26818 -- tool used does not match, or continue as if no tool name
26819 -- was given otherwise, by shifting the arguments.
26821 if Nkind (Argx) = N_Identifier
26822 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
26824 if Chars (Argx) = Name_Gnat then
26825 if CodePeer_Mode or GNATprove_Mode then
26826 Rewrite (N, Make_Null_Statement (Loc));
26831 elsif Chars (Argx) = Name_Gnatprove then
26832 if not GNATprove_Mode then
26833 Rewrite (N, Make_Null_Statement (Loc));
26838 raise Program_Error;
26841 -- At this point, the pragma Warnings applies to the tool,
26842 -- so continue with shifted arguments.
26844 Arg_Count := Arg_Count - 1;
26846 if Arg_Count = 1 then
26847 Shifted_Args := New_List (New_Copy (Arg2));
26848 elsif Arg_Count = 2 then
26849 Shifted_Args := New_List (New_Copy (Arg2),
26851 elsif Arg_Count = 3 then
26852 Shifted_Args := New_List (New_Copy (Arg2),
26856 raise Program_Error;
26861 Chars => Name_Warnings,
26862 Pragma_Argument_Associations => Shifted_Args));
26867 -- One argument case
26869 if Arg_Count = 1 then
26871 -- On/Off one argument case was processed by parser
26873 if Nkind (Argx) = N_Identifier
26874 and then Chars (Argx) in Name_On | Name_Off
26878 -- One argument case must be ON/OFF or static string expr
26880 elsif not Is_Static_String_Expression (Arg1) then
26882 ("argument of pragma% must be On/Off or static string "
26883 & "expression", Arg1);
26885 -- Use of pragma Warnings to set warning switches is
26886 -- ignored in GNATprove mode, as these switches apply to
26887 -- the compiler only.
26889 elsif GNATprove_Mode then
26892 -- One argument string expression case
26896 Lit : constant Node_Id := Expr_Value_S (Argx);
26897 Str : constant String_Id := Strval (Lit);
26898 Len : constant Nat := String_Length (Str);
26906 while J <= Len loop
26907 C := Get_String_Char (Str, J);
26908 OK := In_Character_Range (C);
26911 Chr := Get_Character (C);
26913 -- Dash case: only -Wxxx is accepted
26920 C := Get_String_Char (Str, J);
26921 Chr := Get_Character (C);
26922 exit when Chr = 'W
';
26927 elsif J < Len and then Chr = '.' then
26929 C := Get_String_Char (Str, J);
26930 Chr := Get_Character (C);
26932 if not Set_Warning_Switch ('.', Chr) then
26934 ("invalid warning switch character "
26935 & '.' & Chr, Arg1);
26941 OK := Set_Warning_Switch (Plain, Chr);
26946 ("invalid warning switch character " & Chr,
26952 ("invalid wide character in warning switch ",
26961 -- Two or more arguments (must be two)
26964 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
26965 Check_Arg_Count (2);
26973 E_Id := Get_Pragma_Arg (Arg2);
26976 -- In the expansion of an inlined body, a reference to
26977 -- the formal may be wrapped in a conversion if the
26978 -- actual is a conversion. Retrieve the real entity name.
26980 if (In_Instance_Body or In_Inlined_Body)
26981 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
26983 E_Id := Expression (E_Id);
26986 -- Entity name case
26988 if Is_Entity_Name (E_Id) then
26989 E := Entity (E_Id);
26996 (E, (Chars (Get_Pragma_Arg (Arg1)) =
26999 -- Suppress elaboration warnings if the entity
27000 -- denotes an elaboration target.
27002 if Is_Elaboration_Target (E) then
27003 Set_Is_Elaboration_Warnings_OK_Id (E, False);
27006 -- For OFF case, make entry in warnings off
27007 -- pragma table for later processing. But we do
27008 -- not do that within an instance, since these
27009 -- warnings are about what is needed in the
27010 -- template, not an instance of it.
27012 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
27013 and then Warn_On_Warnings_Off
27014 and then not In_Instance
27016 Warnings_Off_Pragmas.Append ((N, E, Reason));
27019 if Is_Enumeration_Type (E) then
27023 Lit := First_Literal (E);
27024 while Present (Lit) loop
27025 Set_Warnings_Off (Lit);
27026 Next_Literal (Lit);
27031 exit when No (Homonym (E));
27036 -- Error if not entity or static string expression case
27038 elsif not Is_Static_String_Expression (Arg2) then
27040 ("second argument of pragma% must be entity name "
27041 & "or static string expression", Arg2);
27043 -- Static string expression case
27046 -- Note on configuration pragma case: If this is a
27047 -- configuration pragma, then for an OFF pragma, we
27048 -- just set Config True in the call, which is all
27049 -- that needs to be done. For the case of ON, this
27050 -- is normally an error, unless it is canceling the
27051 -- effect of a previous OFF pragma in the same file.
27052 -- In any other case, an error will be signalled (ON
27053 -- with no matching OFF).
27055 -- Note: We set Used if we are inside a generic to
27056 -- disable the test that the non-config case actually
27057 -- cancels a warning. That's because we can't be sure
27058 -- there isn't an instantiation in some other unit
27059 -- where a warning is suppressed.
27061 -- We could do a little better here by checking if the
27062 -- generic unit we are inside is public, but for now
27063 -- we don't bother with that refinement.
27066 Message : constant String :=
27067 Acquire_Warning_Match_String
27068 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
27070 if Chars (Argx) = Name_Off then
27071 Set_Specific_Warning_Off
27072 (Loc, Message, Reason,
27073 Config => Is_Configuration_Pragma,
27074 Used => Inside_A_Generic or else In_Instance);
27076 elsif Chars (Argx) = Name_On then
27077 Set_Specific_Warning_On (Loc, Message, Err);
27081 ("??pragma Warnings On with no matching "
27082 & "Warnings Off", N);
27092 -------------------
27093 -- Weak_External --
27094 -------------------
27096 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
27098 when Pragma_Weak_External => Weak_External : declare
27103 Check_Arg_Count (1);
27104 Check_Optional_Identifier (Arg1, Name_Entity);
27105 Check_Arg_Is_Library_Level_Local_Name (Arg1);
27106 Ent := Entity (Get_Pragma_Arg (Arg1));
27108 if Rep_Item_Too_Early (Ent, N) then
27111 Ent := Underlying_Type (Ent);
27114 -- The pragma applies to entities with addresses
27116 if Is_Type (Ent) then
27117 Error_Pragma ("pragma applies to objects and subprograms");
27120 -- The only processing required is to link this item on to the
27121 -- list of rep items for the given entity. This is accomplished
27122 -- by the call to Rep_Item_Too_Late (when no error is detected
27123 -- and False is returned).
27125 if Rep_Item_Too_Late (Ent, N) then
27128 Set_Has_Gigi_Rep_Item (Ent);
27132 -----------------------------
27133 -- Wide_Character_Encoding --
27134 -----------------------------
27136 -- pragma Wide_Character_Encoding (IDENTIFIER);
27138 when Pragma_Wide_Character_Encoding =>
27141 -- Nothing to do, handled in parser. Note that we do not enforce
27142 -- configuration pragma placement, this pragma can appear at any
27143 -- place in the source, allowing mixed encodings within a single
27148 --------------------
27149 -- Unknown_Pragma --
27150 --------------------
27152 -- Should be impossible, since the case of an unknown pragma is
27153 -- separately processed before the case statement is entered.
27155 when Unknown_Pragma =>
27156 raise Program_Error;
27159 -- AI05-0144: detect dangerous order dependence. Disabled for now,
27160 -- until AI is formally approved.
27162 -- Check_Order_Dependence;
27165 when Pragma_Exit => null;
27166 end Analyze_Pragma;
27168 --------------------------------
27169 -- Analyze_Pragmas_If_Present --
27170 --------------------------------
27172 procedure Analyze_Pragmas_If_Present (Decl : Node_Id; Id : Pragma_Id) is
27175 if Nkind (Parent (Decl)) = N_Compilation_Unit then
27176 Prag := First (Pragmas_After (Aux_Decls_Node (Parent (Decl))));
27178 pragma Assert (Is_List_Member (Decl));
27179 Prag := Next (Decl);
27182 if Present (Prag) then
27183 Analyze_If_Present_Internal (Prag, Id, Included => True);
27185 end Analyze_Pragmas_If_Present;
27187 ---------------------------------------------
27188 -- Analyze_Pre_Post_Condition_In_Decl_Part --
27189 ---------------------------------------------
27191 -- WARNING: This routine manages Ghost regions. Return statements must be
27192 -- replaced by gotos which jump to the end of the routine and restore the
27195 procedure Analyze_Pre_Post_Condition_In_Decl_Part
27197 Freeze_Id : Entity_Id := Empty)
27199 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
27200 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
27202 Disp_Typ : Entity_Id;
27203 -- The dispatching type of the subprogram subject to the pre- or
27206 function Check_References (Nod : Node_Id) return Traverse_Result;
27207 -- Check that expression Nod does not mention non-primitives of the
27208 -- type, global objects of the type, or other illegalities described
27209 -- and implied by AI12-0113.
27211 ----------------------
27212 -- Check_References --
27213 ----------------------
27215 function Check_References (Nod : Node_Id) return Traverse_Result is
27217 if Nkind (Nod) = N_Function_Call
27218 and then Is_Entity_Name (Name (Nod))
27221 Func : constant Entity_Id := Entity (Name (Nod));
27225 -- An operation of the type must be a primitive
27227 if No (Find_Dispatching_Type (Func)) then
27228 Form := First_Formal (Func);
27229 while Present (Form) loop
27230 if Etype (Form) = Disp_Typ then
27232 ("operation in class-wide condition must be "
27233 & "primitive of &", Nod, Disp_Typ);
27236 Next_Formal (Form);
27239 -- A return object of the type is illegal as well
27241 if Etype (Func) = Disp_Typ
27242 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
27245 ("operation in class-wide condition must be primitive "
27246 & "of &", Nod, Disp_Typ);
27251 elsif Is_Entity_Name (Nod)
27253 (Etype (Nod) = Disp_Typ
27254 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27255 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
27258 ("object in class-wide condition must be formal of type &",
27261 elsif Nkind (Nod) = N_Explicit_Dereference
27262 and then (Etype (Nod) = Disp_Typ
27263 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
27264 and then (not Is_Entity_Name (Prefix (Nod))
27265 or else not Is_Formal (Entity (Prefix (Nod))))
27268 ("operation in class-wide condition must be primitive of &",
27273 end Check_References;
27275 procedure Check_Class_Wide_Condition is
27276 new Traverse_Proc (Check_References);
27280 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
27282 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
27283 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
27284 -- Save the Ghost-related attributes to restore on exit
27287 Restore_Scope : Boolean := False;
27289 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
27292 -- Do not analyze the pragma multiple times
27294 if Is_Analyzed_Pragma (N) then
27298 -- Set the Ghost mode in effect from the pragma. Due to the delayed
27299 -- analysis of the pragma, the Ghost mode at point of declaration and
27300 -- point of analysis may not necessarily be the same. Use the mode in
27301 -- effect at the point of declaration.
27303 Set_Ghost_Mode (N);
27305 -- Ensure that the subprogram and its formals are visible when analyzing
27306 -- the expression of the pragma.
27308 if not In_Open_Scopes (Spec_Id) then
27309 Restore_Scope := True;
27311 if Is_Generic_Subprogram (Spec_Id) then
27312 Push_Scope (Spec_Id);
27313 Install_Generic_Formals (Spec_Id);
27314 elsif Is_Access_Subprogram_Type (Spec_Id) then
27315 Push_Scope (Designated_Type (Spec_Id));
27316 Install_Formals (Designated_Type (Spec_Id));
27318 Push_Scope (Spec_Id);
27319 Install_Formals (Spec_Id);
27323 Errors := Serious_Errors_Detected;
27324 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
27326 -- Emit a clarification message when the expression contains at least
27327 -- one undefined reference, possibly due to contract freezing.
27329 if Errors /= Serious_Errors_Detected
27330 and then Present (Freeze_Id)
27331 and then Has_Undefined_Reference (Expr)
27333 Contract_Freeze_Error (Spec_Id, Freeze_Id);
27336 if Class_Present (N) then
27338 -- Verify that a class-wide condition is legal, i.e. the operation is
27339 -- a primitive of a tagged type.
27341 if not Is_Dispatching_Operation (Spec_Id) then
27342 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
27344 if From_Aspect_Specification (N) then
27346 ("aspect % can only be specified for a primitive operation "
27347 & "of a tagged type", Corresponding_Aspect (N));
27349 -- The pragma is a source construct
27353 ("pragma % can only be specified for a primitive operation "
27354 & "of a tagged type", N);
27357 -- Remaining semantic checks require a full tree traversal
27360 Disp_Typ := Find_Dispatching_Type (Spec_Id);
27361 Check_Class_Wide_Condition (Expr);
27366 if Restore_Scope then
27370 -- Currently it is not possible to inline pre/postconditions on a
27371 -- subprogram subject to pragma Inline_Always.
27373 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
27374 Set_Is_Analyzed_Pragma (N);
27376 Restore_Ghost_Region (Saved_GM, Saved_IGR);
27377 end Analyze_Pre_Post_Condition_In_Decl_Part;
27379 ------------------------------------------
27380 -- Analyze_Refined_Depends_In_Decl_Part --
27381 ------------------------------------------
27383 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
27384 procedure Check_Dependency_Clause
27385 (Spec_Id : Entity_Id;
27386 Dep_Clause : Node_Id;
27387 Dep_States : Elist_Id;
27388 Refinements : List_Id;
27389 Matched_Items : in out Elist_Id);
27390 -- Try to match a single dependency clause Dep_Clause against one or
27391 -- more refinement clauses found in list Refinements. Each successful
27392 -- match eliminates at least one refinement clause from Refinements.
27393 -- Spec_Id denotes the entity of the related subprogram. Dep_States
27394 -- denotes the entities of all abstract states which appear in pragma
27395 -- Depends. Matched_Items contains the entities of all successfully
27396 -- matched items found in pragma Depends.
27398 procedure Check_Output_States
27399 (Spec_Inputs : Elist_Id;
27400 Spec_Outputs : Elist_Id;
27401 Body_Inputs : Elist_Id;
27402 Body_Outputs : Elist_Id);
27403 -- Determine whether pragma Depends contains an output state with a
27404 -- visible refinement and if so, ensure that pragma Refined_Depends
27405 -- mentions all its constituents as outputs. Spec_Inputs and
27406 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
27407 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
27408 -- the inputs and outputs of the subprogram body synthesized from pragma
27409 -- Refined_Depends.
27411 function Collect_States (Clauses : List_Id) return Elist_Id;
27412 -- Given a normalized list of dependencies obtained from calling
27413 -- Normalize_Clauses, return a list containing the entities of all
27414 -- states appearing in dependencies. It helps in checking refinements
27415 -- involving a state and a corresponding constituent which is not a
27416 -- direct constituent of the state.
27418 procedure Normalize_Clauses (Clauses : List_Id);
27419 -- Given a list of dependence or refinement clauses Clauses, normalize
27420 -- each clause by creating multiple dependencies with exactly one input
27423 procedure Remove_Extra_Clauses
27424 (Clauses : List_Id;
27425 Matched_Items : Elist_Id);
27426 -- Given a list of refinement clauses Clauses, remove all clauses whose
27427 -- inputs and/or outputs have been previously matched. See the body for
27428 -- all special cases. Matched_Items contains the entities of all matched
27429 -- items found in pragma Depends.
27431 procedure Report_Extra_Clauses (Clauses : List_Id);
27432 -- Emit an error for each extra clause found in list Clauses
27434 -----------------------------
27435 -- Check_Dependency_Clause --
27436 -----------------------------
27438 procedure Check_Dependency_Clause
27439 (Spec_Id : Entity_Id;
27440 Dep_Clause : Node_Id;
27441 Dep_States : Elist_Id;
27442 Refinements : List_Id;
27443 Matched_Items : in out Elist_Id)
27445 Dep_Input : constant Node_Id := Expression (Dep_Clause);
27446 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
27448 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
27449 -- Determine whether dependency item Dep_Item has been matched in a
27450 -- previous clause.
27452 function Is_In_Out_State_Clause return Boolean;
27453 -- Determine whether dependence clause Dep_Clause denotes an abstract
27454 -- state that depends on itself (State => State).
27456 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
27457 -- Determine whether item Item denotes an abstract state with visible
27458 -- null refinement.
27460 procedure Match_Items
27461 (Dep_Item : Node_Id;
27462 Ref_Item : Node_Id;
27463 Matched : out Boolean);
27464 -- Try to match dependence item Dep_Item against refinement item
27465 -- Ref_Item. To match against a possible null refinement (see 2, 9),
27466 -- set Ref_Item to Empty. Flag Matched is set to True when one of
27467 -- the following conformance scenarios is in effect:
27468 -- 1) Both items denote null
27469 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
27470 -- 3) Both items denote attribute 'Result
27471 -- 4) Both items denote the same object
27472 -- 5) Both items denote the same formal parameter
27473 -- 6) Both items denote the same current instance of a type
27474 -- 7) Both items denote the same discriminant
27475 -- 8) Dep_Item is an abstract state with visible null refinement
27476 -- and Ref_Item denotes null.
27477 -- 9) Dep_Item is an abstract state with visible null refinement
27478 -- and Ref_Item is Empty (special case).
27479 -- 10) Dep_Item is an abstract state with full or partial visible
27480 -- non-null refinement and Ref_Item denotes one of its
27482 -- 11) Dep_Item is an abstract state without a full visible
27483 -- refinement and Ref_Item denotes the same state.
27484 -- When scenario 10 is in effect, the entity of the abstract state
27485 -- denoted by Dep_Item is added to list Refined_States.
27487 procedure Record_Item
(Item_Id
: Entity_Id
);
27488 -- Store the entity of an item denoted by Item_Id in Matched_Items
27490 ------------------------
27491 -- Is_Already_Matched --
27492 ------------------------
27494 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
27495 Item_Id
: Entity_Id
:= Empty
;
27498 -- When the dependency item denotes attribute 'Result, check for
27499 -- the entity of the related subprogram.
27501 if Is_Attribute_Result
(Dep_Item
) then
27502 Item_Id
:= Spec_Id
;
27504 elsif Is_Entity_Name
(Dep_Item
) then
27505 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
27509 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
27510 end Is_Already_Matched
;
27512 ----------------------------
27513 -- Is_In_Out_State_Clause --
27514 ----------------------------
27516 function Is_In_Out_State_Clause
return Boolean is
27517 Dep_Input_Id
: Entity_Id
;
27518 Dep_Output_Id
: Entity_Id
;
27521 -- Detect the following clause:
27524 if Is_Entity_Name
(Dep_Input
)
27525 and then Is_Entity_Name
(Dep_Output
)
27527 -- Handle abstract views generated for limited with clauses
27529 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
27530 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
27533 Ekind
(Dep_Input_Id
) = E_Abstract_State
27534 and then Dep_Input_Id
= Dep_Output_Id
;
27538 end Is_In_Out_State_Clause
;
27540 ---------------------------
27541 -- Is_Null_Refined_State --
27542 ---------------------------
27544 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
27545 Item_Id
: Entity_Id
;
27548 if Is_Entity_Name
(Item
) then
27550 -- Handle abstract views generated for limited with clauses
27552 Item_Id
:= Available_View
(Entity_Of
(Item
));
27555 Ekind
(Item_Id
) = E_Abstract_State
27556 and then Has_Null_Visible_Refinement
(Item_Id
);
27560 end Is_Null_Refined_State
;
27566 procedure Match_Items
27567 (Dep_Item
: Node_Id
;
27568 Ref_Item
: Node_Id
;
27569 Matched
: out Boolean)
27571 Dep_Item_Id
: Entity_Id
;
27572 Ref_Item_Id
: Entity_Id
;
27575 -- Assume that the two items do not match
27579 -- A null matches null or Empty (special case)
27581 if Nkind
(Dep_Item
) = N_Null
27582 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
27586 -- Attribute 'Result matches attribute 'Result
27588 elsif Is_Attribute_Result
(Dep_Item
)
27589 and then Is_Attribute_Result
(Ref_Item
)
27591 -- Put the entity of the related function on the list of
27592 -- matched items because attribute 'Result does not carry
27593 -- an entity similar to states and constituents.
27595 Record_Item
(Spec_Id
);
27598 -- Abstract states, current instances of concurrent types,
27599 -- discriminants, formal parameters and objects.
27601 elsif Is_Entity_Name
(Dep_Item
) then
27603 -- Handle abstract views generated for limited with clauses
27605 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
27607 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
27609 -- An abstract state with visible null refinement matches
27610 -- null or Empty (special case).
27612 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
27613 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
27615 Record_Item
(Dep_Item_Id
);
27618 -- An abstract state with visible non-null refinement
27619 -- matches one of its constituents, or itself for an
27620 -- abstract state with partial visible refinement.
27622 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
27623 if Is_Entity_Name
(Ref_Item
) then
27624 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
27626 if Ekind
(Ref_Item_Id
) in
27627 E_Abstract_State | E_Constant | E_Variable
27628 and then Present
(Encapsulating_State
(Ref_Item_Id
))
27629 and then Find_Encapsulating_State
27630 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
27632 Record_Item
(Dep_Item_Id
);
27635 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
27636 and then Ref_Item_Id
= Dep_Item_Id
27638 Record_Item
(Dep_Item_Id
);
27643 -- An abstract state without a visible refinement matches
27646 elsif Is_Entity_Name
(Ref_Item
)
27647 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
27649 Record_Item
(Dep_Item_Id
);
27653 -- A current instance of a concurrent type, discriminant,
27654 -- formal parameter or an object matches itself.
27656 elsif Is_Entity_Name
(Ref_Item
)
27657 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
27659 Record_Item
(Dep_Item_Id
);
27669 procedure Record_Item
(Item_Id
: Entity_Id
) is
27671 if No
(Matched_Items
) then
27672 Matched_Items
:= New_Elmt_List
;
27675 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
27680 Clause_Matched
: Boolean := False;
27681 Dummy
: Boolean := False;
27682 Inputs_Match
: Boolean;
27683 Next_Ref_Clause
: Node_Id
;
27684 Outputs_Match
: Boolean;
27685 Ref_Clause
: Node_Id
;
27686 Ref_Input
: Node_Id
;
27687 Ref_Output
: Node_Id
;
27689 -- Start of processing for Check_Dependency_Clause
27692 -- Do not perform this check in an instance because it was already
27693 -- performed successfully in the generic template.
27695 if In_Instance
then
27699 -- Examine all refinement clauses and compare them against the
27700 -- dependence clause.
27702 Ref_Clause
:= First
(Refinements
);
27703 while Present
(Ref_Clause
) loop
27704 Next_Ref_Clause
:= Next
(Ref_Clause
);
27706 -- Obtain the attributes of the current refinement clause
27708 Ref_Input
:= Expression
(Ref_Clause
);
27709 Ref_Output
:= First
(Choices
(Ref_Clause
));
27711 -- The current refinement clause matches the dependence clause
27712 -- when both outputs match and both inputs match. See routine
27713 -- Match_Items for all possible conformance scenarios.
27715 -- Depends Dep_Output => Dep_Input
27719 -- Refined_Depends Ref_Output => Ref_Input
27722 (Dep_Item
=> Dep_Input
,
27723 Ref_Item
=> Ref_Input
,
27724 Matched
=> Inputs_Match
);
27727 (Dep_Item
=> Dep_Output
,
27728 Ref_Item
=> Ref_Output
,
27729 Matched
=> Outputs_Match
);
27731 -- An In_Out state clause may be matched against a refinement with
27732 -- a null input or null output as long as the non-null side of the
27733 -- relation contains a valid constituent of the In_Out_State.
27735 if Is_In_Out_State_Clause
then
27737 -- Depends => (State => State)
27738 -- Refined_Depends => (null => Constit) -- OK
27741 and then not Outputs_Match
27742 and then Nkind
(Ref_Output
) = N_Null
27744 Outputs_Match
:= True;
27747 -- Depends => (State => State)
27748 -- Refined_Depends => (Constit => null) -- OK
27750 if not Inputs_Match
27751 and then Outputs_Match
27752 and then Nkind
(Ref_Input
) = N_Null
27754 Inputs_Match
:= True;
27758 -- The current refinement clause is legally constructed following
27759 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
27760 -- the pool of candidates. The search continues because a single
27761 -- dependence clause may have multiple matching refinements.
27763 if Inputs_Match
and Outputs_Match
then
27764 Clause_Matched
:= True;
27765 Remove
(Ref_Clause
);
27768 Ref_Clause
:= Next_Ref_Clause
;
27771 -- Depending on the order or composition of refinement clauses, an
27772 -- In_Out state clause may not be directly refinable.
27774 -- Refined_State => (State => (Constit_1, Constit_2))
27775 -- Depends => ((Output, State) => (Input, State))
27776 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
27778 -- Matching normalized clause (State => State) fails because there is
27779 -- no direct refinement capable of satisfying this relation. Another
27780 -- similar case arises when clauses (Constit_1 => Input) and (Output
27781 -- => Constit_2) are matched first, leaving no candidates for clause
27782 -- (State => State). Both scenarios are legal as long as one of the
27783 -- previous clauses mentioned a valid constituent of State.
27785 if not Clause_Matched
27786 and then Is_In_Out_State_Clause
27787 and then Is_Already_Matched
(Dep_Input
)
27789 Clause_Matched
:= True;
27792 -- A clause where the input is an abstract state with visible null
27793 -- refinement or a 'Result attribute is implicitly matched when the
27794 -- output has already been matched in a previous clause.
27796 -- Refined_State => (State => null)
27797 -- Depends => (Output => State) -- implicitly OK
27798 -- Refined_Depends => (Output => ...)
27799 -- Depends => (...'Result => State) -- implicitly OK
27800 -- Refined_Depends => (...'Result => ...)
27802 if not Clause_Matched
27803 and then Is_Null_Refined_State
(Dep_Input
)
27804 and then Is_Already_Matched
(Dep_Output
)
27806 Clause_Matched
:= True;
27809 -- A clause where the output is an abstract state with visible null
27810 -- refinement is implicitly matched when the input has already been
27811 -- matched in a previous clause.
27813 -- Refined_State => (State => null)
27814 -- Depends => (State => Input) -- implicitly OK
27815 -- Refined_Depends => (... => Input)
27817 if not Clause_Matched
27818 and then Is_Null_Refined_State
(Dep_Output
)
27819 and then Is_Already_Matched
(Dep_Input
)
27821 Clause_Matched
:= True;
27824 -- At this point either all refinement clauses have been examined or
27825 -- pragma Refined_Depends contains a solitary null. Only an abstract
27826 -- state with null refinement can possibly match these cases.
27828 -- Refined_State => (State => null)
27829 -- Depends => (State => null)
27830 -- Refined_Depends => null -- OK
27832 if not Clause_Matched
then
27834 (Dep_Item
=> Dep_Input
,
27836 Matched
=> Inputs_Match
);
27839 (Dep_Item
=> Dep_Output
,
27841 Matched
=> Outputs_Match
);
27843 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
27846 -- If the contents of Refined_Depends are legal, then the current
27847 -- dependence clause should be satisfied either by an explicit match
27848 -- or by one of the special cases.
27850 if not Clause_Matched
then
27852 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
27853 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
27855 end Check_Dependency_Clause
;
27857 -------------------------
27858 -- Check_Output_States --
27859 -------------------------
27861 procedure Check_Output_States
27862 (Spec_Inputs
: Elist_Id
;
27863 Spec_Outputs
: Elist_Id
;
27864 Body_Inputs
: Elist_Id
;
27865 Body_Outputs
: Elist_Id
)
27867 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27868 -- Determine whether all constituents of state State_Id with full
27869 -- visible refinement are used as outputs in pragma Refined_Depends.
27870 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
27872 -----------------------------
27873 -- Check_Constituent_Usage --
27874 -----------------------------
27876 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27877 Constits
: constant Elist_Id
:=
27878 Partial_Refinement_Constituents
(State_Id
);
27879 Constit_Elmt
: Elmt_Id
;
27880 Constit_Id
: Entity_Id
;
27881 Only_Partial
: constant Boolean :=
27882 not Has_Visible_Refinement
(State_Id
);
27883 Posted
: Boolean := False;
27886 if Present
(Constits
) then
27887 Constit_Elmt
:= First_Elmt
(Constits
);
27888 while Present
(Constit_Elmt
) loop
27889 Constit_Id
:= Node
(Constit_Elmt
);
27891 -- Issue an error when a constituent of State_Id is used,
27892 -- and State_Id has only partial visible refinement
27893 -- (SPARK RM 7.2.4(3d)).
27895 if Only_Partial
then
27896 if (Present
(Body_Inputs
)
27897 and then Appears_In
(Body_Inputs
, Constit_Id
))
27899 (Present
(Body_Outputs
)
27900 and then Appears_In
(Body_Outputs
, Constit_Id
))
27902 Error_Msg_Name_1
:= Chars
(State_Id
);
27904 ("constituent & of state % cannot be used in "
27905 & "dependence refinement", N
, Constit_Id
);
27906 Error_Msg_Name_1
:= Chars
(State_Id
);
27907 SPARK_Msg_N
("\use state % instead", N
);
27910 -- The constituent acts as an input (SPARK RM 7.2.5(3))
27912 elsif Present
(Body_Inputs
)
27913 and then Appears_In
(Body_Inputs
, Constit_Id
)
27915 Error_Msg_Name_1
:= Chars
(State_Id
);
27917 ("constituent & of state % must act as output in "
27918 & "dependence refinement", N
, Constit_Id
);
27920 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27922 elsif No
(Body_Outputs
)
27923 or else not Appears_In
(Body_Outputs
, Constit_Id
)
27928 ("output state & must be replaced by all its "
27929 & "constituents in dependence refinement",
27934 ("\constituent & is missing in output list",
27938 Next_Elmt
(Constit_Elmt
);
27941 end Check_Constituent_Usage
;
27946 Item_Elmt
: Elmt_Id
;
27947 Item_Id
: Entity_Id
;
27949 -- Start of processing for Check_Output_States
27952 -- Do not perform this check in an instance because it was already
27953 -- performed successfully in the generic template.
27955 if In_Instance
then
27958 -- Inspect the outputs of pragma Depends looking for a state with a
27959 -- visible refinement.
27961 elsif Present
(Spec_Outputs
) then
27962 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
27963 while Present
(Item_Elmt
) loop
27964 Item
:= Node
(Item_Elmt
);
27966 -- Deal with the mixed nature of the input and output lists
27968 if Nkind
(Item
) = N_Defining_Identifier
then
27971 Item_Id
:= Available_View
(Entity_Of
(Item
));
27974 if Ekind
(Item_Id
) = E_Abstract_State
then
27976 -- The state acts as an input-output, skip it
27978 if Present
(Spec_Inputs
)
27979 and then Appears_In
(Spec_Inputs
, Item_Id
)
27983 -- Ensure that all of the constituents are utilized as
27984 -- outputs in pragma Refined_Depends.
27986 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27987 Check_Constituent_Usage
(Item_Id
);
27991 Next_Elmt
(Item_Elmt
);
27994 end Check_Output_States
;
27996 --------------------
27997 -- Collect_States --
27998 --------------------
28000 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
28001 procedure Collect_State
28003 States
: in out Elist_Id
);
28004 -- Add the entity of Item to list States when it denotes to a state
28006 -------------------
28007 -- Collect_State --
28008 -------------------
28010 procedure Collect_State
28012 States
: in out Elist_Id
)
28017 if Is_Entity_Name
(Item
) then
28018 Id
:= Entity_Of
(Item
);
28020 if Ekind
(Id
) = E_Abstract_State
then
28021 if No
(States
) then
28022 States
:= New_Elmt_List
;
28025 Append_Unique_Elmt
(Id
, States
);
28035 States
: Elist_Id
:= No_Elist
;
28037 -- Start of processing for Collect_States
28040 Clause
:= First
(Clauses
);
28041 while Present
(Clause
) loop
28042 Input
:= Expression
(Clause
);
28043 Output
:= First
(Choices
(Clause
));
28045 Collect_State
(Input
, States
);
28046 Collect_State
(Output
, States
);
28052 end Collect_States
;
28054 -----------------------
28055 -- Normalize_Clauses --
28056 -----------------------
28058 procedure Normalize_Clauses
(Clauses
: List_Id
) is
28059 procedure Normalize_Inputs
(Clause
: Node_Id
);
28060 -- Normalize clause Clause by creating multiple clauses for each
28061 -- input item of Clause. It is assumed that Clause has exactly one
28062 -- output. The transformation is as follows:
28064 -- Output => (Input_1, Input_2) -- original
28066 -- Output => Input_1 -- normalizations
28067 -- Output => Input_2
28069 procedure Normalize_Outputs
(Clause
: Node_Id
);
28070 -- Normalize clause Clause by creating multiple clause for each
28071 -- output item of Clause. The transformation is as follows:
28073 -- (Output_1, Output_2) => Input -- original
28075 -- Output_1 => Input -- normalization
28076 -- Output_2 => Input
28078 ----------------------
28079 -- Normalize_Inputs --
28080 ----------------------
28082 procedure Normalize_Inputs
(Clause
: Node_Id
) is
28083 Inputs
: constant Node_Id
:= Expression
(Clause
);
28084 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
28085 Output
: constant List_Id
:= Choices
(Clause
);
28086 Last_Input
: Node_Id
;
28088 New_Clause
: Node_Id
;
28089 Next_Input
: Node_Id
;
28092 -- Normalization is performed only when the original clause has
28093 -- more than one input. Multiple inputs appear as an aggregate.
28095 if Nkind
(Inputs
) = N_Aggregate
then
28096 Last_Input
:= Last
(Expressions
(Inputs
));
28098 -- Create a new clause for each input
28100 Input
:= First
(Expressions
(Inputs
));
28101 while Present
(Input
) loop
28102 Next_Input
:= Next
(Input
);
28104 -- Unhook the current input from the original input list
28105 -- because it will be relocated to a new clause.
28109 -- Special processing for the last input. At this point the
28110 -- original aggregate has been stripped down to one element.
28111 -- Replace the aggregate by the element itself.
28113 if Input
= Last_Input
then
28114 Rewrite
(Inputs
, Input
);
28116 -- Generate a clause of the form:
28121 Make_Component_Association
(Loc
,
28122 Choices
=> New_Copy_List_Tree
(Output
),
28123 Expression
=> Input
);
28125 -- The new clause contains replicated content that has
28126 -- already been analyzed, mark the clause as analyzed.
28128 Set_Analyzed
(New_Clause
);
28129 Insert_After
(Clause
, New_Clause
);
28132 Input
:= Next_Input
;
28135 end Normalize_Inputs
;
28137 -----------------------
28138 -- Normalize_Outputs --
28139 -----------------------
28141 procedure Normalize_Outputs
(Clause
: Node_Id
) is
28142 Inputs
: constant Node_Id
:= Expression
(Clause
);
28143 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
28144 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
28145 Last_Output
: Node_Id
;
28146 New_Clause
: Node_Id
;
28147 Next_Output
: Node_Id
;
28151 -- Multiple outputs appear as an aggregate. Nothing to do when
28152 -- the clause has exactly one output.
28154 if Nkind
(Outputs
) = N_Aggregate
then
28155 Last_Output
:= Last
(Expressions
(Outputs
));
28157 -- Create a clause for each output. Note that each time a new
28158 -- clause is created, the original output list slowly shrinks
28159 -- until there is one item left.
28161 Output
:= First
(Expressions
(Outputs
));
28162 while Present
(Output
) loop
28163 Next_Output
:= Next
(Output
);
28165 -- Unhook the output from the original output list as it
28166 -- will be relocated to a new clause.
28170 -- Special processing for the last output. At this point
28171 -- the original aggregate has been stripped down to one
28172 -- element. Replace the aggregate by the element itself.
28174 if Output
= Last_Output
then
28175 Rewrite
(Outputs
, Output
);
28178 -- Generate a clause of the form:
28179 -- (Output => Inputs)
28182 Make_Component_Association
(Loc
,
28183 Choices
=> New_List
(Output
),
28184 Expression
=> New_Copy_Tree
(Inputs
));
28186 -- The new clause contains replicated content that has
28187 -- already been analyzed. There is not need to reanalyze
28190 Set_Analyzed
(New_Clause
);
28191 Insert_After
(Clause
, New_Clause
);
28194 Output
:= Next_Output
;
28197 end Normalize_Outputs
;
28203 -- Start of processing for Normalize_Clauses
28206 Clause
:= First
(Clauses
);
28207 while Present
(Clause
) loop
28208 Normalize_Outputs
(Clause
);
28212 Clause
:= First
(Clauses
);
28213 while Present
(Clause
) loop
28214 Normalize_Inputs
(Clause
);
28217 end Normalize_Clauses
;
28219 --------------------------
28220 -- Remove_Extra_Clauses --
28221 --------------------------
28223 procedure Remove_Extra_Clauses
28224 (Clauses
: List_Id
;
28225 Matched_Items
: Elist_Id
)
28229 Input_Id
: Entity_Id
;
28230 Next_Clause
: Node_Id
;
28232 State_Id
: Entity_Id
;
28235 Clause
:= First
(Clauses
);
28236 while Present
(Clause
) loop
28237 Next_Clause
:= Next
(Clause
);
28239 Input
:= Expression
(Clause
);
28240 Output
:= First
(Choices
(Clause
));
28242 -- Recognize a clause of the form
28246 -- where Input is a constituent of a state which was already
28247 -- successfully matched. This clause must be removed because it
28248 -- simply indicates that some of the constituents of the state
28251 -- Refined_State => (State => (Constit_1, Constit_2))
28252 -- Depends => (Output => State)
28253 -- Refined_Depends => ((Output => Constit_1), -- State matched
28254 -- (null => Constit_2)) -- OK
28256 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
28258 -- Handle abstract views generated for limited with clauses
28260 Input_Id
:= Available_View
(Entity_Of
(Input
));
28262 -- The input must be a constituent of a state
28264 if Ekind
(Input_Id
) in
28265 E_Abstract_State | E_Constant | E_Variable
28266 and then Present
(Encapsulating_State
(Input_Id
))
28268 State_Id
:= Encapsulating_State
(Input_Id
);
28270 -- The state must have a non-null visible refinement and be
28271 -- matched in a previous clause.
28273 if Has_Non_Null_Visible_Refinement
(State_Id
)
28274 and then Contains
(Matched_Items
, State_Id
)
28280 -- Recognize a clause of the form
28284 -- where Output is an arbitrary item. This clause must be removed
28285 -- because a null input legitimately matches anything.
28287 elsif Nkind
(Input
) = N_Null
then
28291 Clause
:= Next_Clause
;
28293 end Remove_Extra_Clauses
;
28295 --------------------------
28296 -- Report_Extra_Clauses --
28297 --------------------------
28299 procedure Report_Extra_Clauses
(Clauses
: List_Id
) is
28303 -- Do not perform this check in an instance because it was already
28304 -- performed successfully in the generic template.
28306 if In_Instance
then
28309 elsif Present
(Clauses
) then
28310 Clause
:= First
(Clauses
);
28311 while Present
(Clause
) loop
28313 ("unmatched or extra clause in dependence refinement",
28319 end Report_Extra_Clauses
;
28323 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28324 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28325 Errors
: constant Nat
:= Serious_Errors_Detected
;
28332 Body_Inputs
: Elist_Id
:= No_Elist
;
28333 Body_Outputs
: Elist_Id
:= No_Elist
;
28334 -- The inputs and outputs of the subprogram body synthesized from pragma
28335 -- Refined_Depends.
28337 Dependencies
: List_Id
:= No_List
;
28339 -- The corresponding Depends pragma along with its clauses
28341 Matched_Items
: Elist_Id
:= No_Elist
;
28342 -- A list containing the entities of all successfully matched items
28343 -- found in pragma Depends.
28345 Refinements
: List_Id
:= No_List
;
28346 -- The clauses of pragma Refined_Depends
28348 Spec_Id
: Entity_Id
;
28349 -- The entity of the subprogram subject to pragma Refined_Depends
28351 Spec_Inputs
: Elist_Id
:= No_Elist
;
28352 Spec_Outputs
: Elist_Id
:= No_Elist
;
28353 -- The inputs and outputs of the subprogram spec synthesized from pragma
28356 States
: Elist_Id
:= No_Elist
;
28357 -- A list containing the entities of all states whose constituents
28358 -- appear in pragma Depends.
28360 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
28363 -- Do not analyze the pragma multiple times
28365 if Is_Analyzed_Pragma
(N
) then
28369 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28371 -- Use the anonymous object as the proper spec when Refined_Depends
28372 -- applies to the body of a single task type. The object carries the
28373 -- proper Chars as well as all non-refined versions of pragmas.
28375 if Is_Single_Concurrent_Type
(Spec_Id
) then
28376 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28379 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28381 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
28382 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
28384 if No
(Depends
) then
28386 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28387 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
28391 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28393 -- A null dependency relation renders the refinement useless because it
28394 -- cannot possibly mention abstract states with visible refinement. Note
28395 -- that the inverse is not true as states may be refined to null
28396 -- (SPARK RM 7.2.5(2)).
28398 if Nkind
(Deps
) = N_Null
then
28400 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28401 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
28405 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
28406 -- This ensures that the categorization of all refined dependency items
28407 -- is consistent with their role.
28409 Analyze_Depends_In_Decl_Part
(N
);
28411 -- Do not match dependencies against refinements if Refined_Depends is
28412 -- illegal to avoid emitting misleading error.
28414 if Serious_Errors_Detected
= Errors
then
28416 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
28417 -- the inputs and outputs of the subprogram spec and body to verify
28418 -- the use of states with visible refinement and their constituents.
28420 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
28421 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
28423 Collect_Subprogram_Inputs_Outputs
28424 (Subp_Id
=> Spec_Id
,
28425 Synthesize
=> True,
28426 Subp_Inputs
=> Spec_Inputs
,
28427 Subp_Outputs
=> Spec_Outputs
,
28428 Global_Seen
=> Dummy
);
28430 Collect_Subprogram_Inputs_Outputs
28431 (Subp_Id
=> Body_Id
,
28432 Synthesize
=> True,
28433 Subp_Inputs
=> Body_Inputs
,
28434 Subp_Outputs
=> Body_Outputs
,
28435 Global_Seen
=> Dummy
);
28437 -- For an output state with a visible refinement, ensure that all
28438 -- constituents appear as outputs in the dependency refinement.
28440 Check_Output_States
28441 (Spec_Inputs
=> Spec_Inputs
,
28442 Spec_Outputs
=> Spec_Outputs
,
28443 Body_Inputs
=> Body_Inputs
,
28444 Body_Outputs
=> Body_Outputs
);
28447 -- Multiple dependency clauses appear as component associations of an
28448 -- aggregate. Note that the clauses are copied because the algorithm
28449 -- modifies them and this should not be visible in Depends.
28451 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
28452 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
28453 Normalize_Clauses
(Dependencies
);
28455 -- Gather all states which appear in Depends
28457 States
:= Collect_States
(Dependencies
);
28459 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
28461 if Nkind
(Refs
) = N_Null
then
28462 Refinements
:= No_List
;
28464 -- Multiple dependency clauses appear as component associations of an
28465 -- aggregate. Note that the clauses are copied because the algorithm
28466 -- modifies them and this should not be visible in Refined_Depends.
28468 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
28469 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
28470 Normalize_Clauses
(Refinements
);
28473 -- At this point the clauses of pragmas Depends and Refined_Depends
28474 -- have been normalized into simple dependencies between one output
28475 -- and one input. Examine all clauses of pragma Depends looking for
28476 -- matching clauses in pragma Refined_Depends.
28478 Clause
:= First
(Dependencies
);
28479 while Present
(Clause
) loop
28480 Check_Dependency_Clause
28481 (Spec_Id
=> Spec_Id
,
28482 Dep_Clause
=> Clause
,
28483 Dep_States
=> States
,
28484 Refinements
=> Refinements
,
28485 Matched_Items
=> Matched_Items
);
28490 -- Pragma Refined_Depends may contain multiple clarification clauses
28491 -- which indicate that certain constituents do not influence the data
28492 -- flow in any way. Such clauses must be removed as long as the state
28493 -- has been matched, otherwise they will be incorrectly flagged as
28496 -- Refined_State => (State => (Constit_1, Constit_2))
28497 -- Depends => (Output => State)
28498 -- Refined_Depends => ((Output => Constit_1), -- State matched
28499 -- (null => Constit_2)) -- must be removed
28501 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
28503 if Serious_Errors_Detected
= Errors
then
28504 Report_Extra_Clauses
(Refinements
);
28509 Set_Is_Analyzed_Pragma
(N
);
28510 end Analyze_Refined_Depends_In_Decl_Part
;
28512 -----------------------------------------
28513 -- Analyze_Refined_Global_In_Decl_Part --
28514 -----------------------------------------
28516 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
28518 -- The corresponding Global pragma
28520 Has_In_State
: Boolean := False;
28521 Has_In_Out_State
: Boolean := False;
28522 Has_Out_State
: Boolean := False;
28523 Has_Proof_In_State
: Boolean := False;
28524 -- These flags are set when the corresponding Global pragma has a state
28525 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
28528 Has_Null_State
: Boolean := False;
28529 -- This flag is set when the corresponding Global pragma has at least
28530 -- one state with a null refinement.
28532 In_Constits
: Elist_Id
:= No_Elist
;
28533 In_Out_Constits
: Elist_Id
:= No_Elist
;
28534 Out_Constits
: Elist_Id
:= No_Elist
;
28535 Proof_In_Constits
: Elist_Id
:= No_Elist
;
28536 -- These lists contain the entities of all Input, In_Out, Output and
28537 -- Proof_In constituents that appear in Refined_Global and participate
28538 -- in state refinement.
28540 In_Items
: Elist_Id
:= No_Elist
;
28541 In_Out_Items
: Elist_Id
:= No_Elist
;
28542 Out_Items
: Elist_Id
:= No_Elist
;
28543 Proof_In_Items
: Elist_Id
:= No_Elist
;
28544 -- These lists contain the entities of all Input, In_Out, Output and
28545 -- Proof_In items defined in the corresponding Global pragma.
28547 Repeat_Items
: Elist_Id
:= No_Elist
;
28548 -- A list of all global items without full visible refinement found
28549 -- in pragma Global. These states should be repeated in the global
28550 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
28551 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
28553 Spec_Id
: Entity_Id
;
28554 -- The entity of the subprogram subject to pragma Refined_Global
28556 States
: Elist_Id
:= No_Elist
;
28557 -- A list of all states with full or partial visible refinement found in
28560 procedure Check_In_Out_States
;
28561 -- Determine whether the corresponding Global pragma mentions In_Out
28562 -- states with visible refinement and if so, ensure that one of the
28563 -- following completions apply to the constituents of the state:
28564 -- 1) there is at least one constituent of mode In_Out
28565 -- 2) there is at least one Input and one Output constituent
28566 -- 3) not all constituents are present and one of them is of mode
28568 -- This routine may remove elements from In_Constits, In_Out_Constits,
28569 -- Out_Constits and Proof_In_Constits.
28571 procedure Check_Input_States
;
28572 -- Determine whether the corresponding Global pragma mentions Input
28573 -- states with visible refinement and if so, ensure that at least one of
28574 -- its constituents appears as an Input item in Refined_Global.
28575 -- This routine may remove elements from In_Constits, In_Out_Constits,
28576 -- Out_Constits and Proof_In_Constits.
28578 procedure Check_Output_States
;
28579 -- Determine whether the corresponding Global pragma mentions Output
28580 -- states with visible refinement and if so, ensure that all of its
28581 -- constituents appear as Output items in Refined_Global.
28582 -- This routine may remove elements from In_Constits, In_Out_Constits,
28583 -- Out_Constits and Proof_In_Constits.
28585 procedure Check_Proof_In_States
;
28586 -- Determine whether the corresponding Global pragma mentions Proof_In
28587 -- states with visible refinement and if so, ensure that at least one of
28588 -- its constituents appears as a Proof_In item in Refined_Global.
28589 -- This routine may remove elements from In_Constits, In_Out_Constits,
28590 -- Out_Constits and Proof_In_Constits.
28592 procedure Check_Refined_Global_List
28594 Global_Mode
: Name_Id
:= Name_Input
);
28595 -- Verify the legality of a single global list declaration. Global_Mode
28596 -- denotes the current mode in effect.
28598 procedure Collect_Global_Items
28600 Mode
: Name_Id
:= Name_Input
);
28601 -- Gather all Input, In_Out, Output and Proof_In items from node List
28602 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
28603 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
28604 -- and Has_Proof_In_State are set when there is at least one abstract
28605 -- state with full or partial visible refinement available in the
28606 -- corresponding mode. Flag Has_Null_State is set when at least state
28607 -- has a null refinement. Mode denotes the current global mode in
28610 function Present_Then_Remove
28612 Item
: Entity_Id
) return Boolean;
28613 -- Search List for a particular entity Item. If Item has been found,
28614 -- remove it from List. This routine is used to strip lists In_Constits,
28615 -- In_Out_Constits and Out_Constits of valid constituents.
28617 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
28618 -- Same as function Present_Then_Remove, but do not report the presence
28619 -- of Item in List.
28621 procedure Report_Extra_Constituents
;
28622 -- Emit an error for each constituent found in lists In_Constits,
28623 -- In_Out_Constits and Out_Constits.
28625 procedure Report_Missing_Items
;
28626 -- Emit an error for each global item not repeated found in list
28629 -------------------------
28630 -- Check_In_Out_States --
28631 -------------------------
28633 procedure Check_In_Out_States
is
28634 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28635 -- Determine whether one of the following coverage scenarios is in
28637 -- 1) there is at least one constituent of mode In_Out or Output
28638 -- 2) there is at least one pair of constituents with modes Input
28639 -- and Output, or Proof_In and Output.
28640 -- 3) there is at least one constituent of mode Output and not all
28641 -- constituents are present.
28642 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
28644 -----------------------------
28645 -- Check_Constituent_Usage --
28646 -----------------------------
28648 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28649 Constits
: constant Elist_Id
:=
28650 Partial_Refinement_Constituents
(State_Id
);
28651 Constit_Elmt
: Elmt_Id
;
28652 Constit_Id
: Entity_Id
;
28653 Has_Missing
: Boolean := False;
28654 In_Out_Seen
: Boolean := False;
28655 Input_Seen
: Boolean := False;
28656 Output_Seen
: Boolean := False;
28657 Proof_In_Seen
: Boolean := False;
28660 -- Process all the constituents of the state and note their modes
28661 -- within the global refinement.
28663 if Present
(Constits
) then
28664 Constit_Elmt
:= First_Elmt
(Constits
);
28665 while Present
(Constit_Elmt
) loop
28666 Constit_Id
:= Node
(Constit_Elmt
);
28668 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
28669 Input_Seen
:= True;
28671 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
28672 In_Out_Seen
:= True;
28674 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
28675 Output_Seen
:= True;
28677 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28679 Proof_In_Seen
:= True;
28682 Has_Missing
:= True;
28685 Next_Elmt
(Constit_Elmt
);
28689 -- An In_Out constituent is a valid completion
28691 if In_Out_Seen
then
28694 -- A pair of one Input/Proof_In and one Output constituent is a
28695 -- valid completion.
28697 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
28700 elsif Output_Seen
then
28702 -- A single Output constituent is a valid completion only when
28703 -- some of the other constituents are missing.
28705 if Has_Missing
then
28708 -- Otherwise all constituents are of mode Output
28712 ("global refinement of state & must include at least one "
28713 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
28717 -- The state lacks a completion. When full refinement is visible,
28718 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
28719 -- refinement is visible, emit an error if the abstract state
28720 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
28721 -- both are utilized, Check_State_And_Constituent_Use. will issue
28724 elsif not Input_Seen
28725 and then not In_Out_Seen
28726 and then not Output_Seen
28727 and then not Proof_In_Seen
28729 if Has_Visible_Refinement
(State_Id
)
28730 or else Contains
(Repeat_Items
, State_Id
)
28733 ("missing global refinement of state &", N
, State_Id
);
28736 -- Otherwise the state has a malformed completion where at least
28737 -- one of the constituents has a different mode.
28741 ("global refinement of state & redefines the mode of its "
28742 & "constituents", N
, State_Id
);
28744 end Check_Constituent_Usage
;
28748 Item_Elmt
: Elmt_Id
;
28749 Item_Id
: Entity_Id
;
28751 -- Start of processing for Check_In_Out_States
28754 -- Do not perform this check in an instance because it was already
28755 -- performed successfully in the generic template.
28757 if In_Instance
then
28760 -- Inspect the In_Out items of the corresponding Global pragma
28761 -- looking for a state with a visible refinement.
28763 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
28764 Item_Elmt
:= First_Elmt
(In_Out_Items
);
28765 while Present
(Item_Elmt
) loop
28766 Item_Id
:= Node
(Item_Elmt
);
28768 -- Ensure that one of the three coverage variants is satisfied
28770 if Ekind
(Item_Id
) = E_Abstract_State
28771 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28773 Check_Constituent_Usage
(Item_Id
);
28776 Next_Elmt
(Item_Elmt
);
28779 end Check_In_Out_States
;
28781 ------------------------
28782 -- Check_Input_States --
28783 ------------------------
28785 procedure Check_Input_States
is
28786 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28787 -- Determine whether at least one constituent of state State_Id with
28788 -- full or partial visible refinement is used and has mode Input.
28789 -- Ensure that the remaining constituents do not have In_Out or
28790 -- Output modes. Emit an error if this is not the case
28791 -- (SPARK RM 7.2.4(5)).
28793 -----------------------------
28794 -- Check_Constituent_Usage --
28795 -----------------------------
28797 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28798 Constits
: constant Elist_Id
:=
28799 Partial_Refinement_Constituents
(State_Id
);
28800 Constit_Elmt
: Elmt_Id
;
28801 Constit_Id
: Entity_Id
;
28802 In_Seen
: Boolean := False;
28805 if Present
(Constits
) then
28806 Constit_Elmt
:= First_Elmt
(Constits
);
28807 while Present
(Constit_Elmt
) loop
28808 Constit_Id
:= Node
(Constit_Elmt
);
28810 -- At least one of the constituents appears as an Input
28812 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
28815 -- A Proof_In constituent can refine an Input state as long
28816 -- as there is at least one Input constituent present.
28818 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28822 -- The constituent appears in the global refinement, but has
28823 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
28825 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28826 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
28828 Error_Msg_Name_1
:= Chars
(State_Id
);
28830 ("constituent & of state % must have mode `Input` in "
28831 & "global refinement", N
, Constit_Id
);
28834 Next_Elmt
(Constit_Elmt
);
28838 -- Not one of the constituents appeared as Input. Always emit an
28839 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
28840 -- When only partial refinement is visible, emit an error if the
28841 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
28842 -- the case where both are utilized, an error will be issued in
28843 -- Check_State_And_Constituent_Use.
28846 and then (Has_Visible_Refinement
(State_Id
)
28847 or else Contains
(Repeat_Items
, State_Id
))
28850 ("global refinement of state & must include at least one "
28851 & "constituent of mode `Input`", N
, State_Id
);
28853 end Check_Constituent_Usage
;
28857 Item_Elmt
: Elmt_Id
;
28858 Item_Id
: Entity_Id
;
28860 -- Start of processing for Check_Input_States
28863 -- Do not perform this check in an instance because it was already
28864 -- performed successfully in the generic template.
28866 if In_Instance
then
28869 -- Inspect the Input items of the corresponding Global pragma looking
28870 -- for a state with a visible refinement.
28872 elsif Has_In_State
and then Present
(In_Items
) then
28873 Item_Elmt
:= First_Elmt
(In_Items
);
28874 while Present
(Item_Elmt
) loop
28875 Item_Id
:= Node
(Item_Elmt
);
28877 -- When full refinement is visible, ensure that at least one of
28878 -- the constituents is utilized and is of mode Input. When only
28879 -- partial refinement is visible, ensure that either one of
28880 -- the constituents is utilized and is of mode Input, or the
28881 -- abstract state is repeated and no constituent is utilized.
28883 if Ekind
(Item_Id
) = E_Abstract_State
28884 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28886 Check_Constituent_Usage
(Item_Id
);
28889 Next_Elmt
(Item_Elmt
);
28892 end Check_Input_States
;
28894 -------------------------
28895 -- Check_Output_States --
28896 -------------------------
28898 procedure Check_Output_States
is
28899 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
28900 -- Determine whether all constituents of state State_Id with full
28901 -- visible refinement are used and have mode Output. Emit an error
28902 -- if this is not the case (SPARK RM 7.2.4(5)).
28904 -----------------------------
28905 -- Check_Constituent_Usage --
28906 -----------------------------
28908 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
28909 Constits
: constant Elist_Id
:=
28910 Partial_Refinement_Constituents
(State_Id
);
28911 Only_Partial
: constant Boolean :=
28912 not Has_Visible_Refinement
(State_Id
);
28913 Constit_Elmt
: Elmt_Id
;
28914 Constit_Id
: Entity_Id
;
28915 Posted
: Boolean := False;
28918 if Present
(Constits
) then
28919 Constit_Elmt
:= First_Elmt
(Constits
);
28920 while Present
(Constit_Elmt
) loop
28921 Constit_Id
:= Node
(Constit_Elmt
);
28923 -- Issue an error when a constituent of State_Id is utilized
28924 -- and State_Id has only partial visible refinement
28925 -- (SPARK RM 7.2.4(3d)).
28927 if Only_Partial
then
28928 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
28929 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
28931 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28933 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28935 Error_Msg_Name_1
:= Chars
(State_Id
);
28937 ("constituent & of state % cannot be used in global "
28938 & "refinement", N
, Constit_Id
);
28939 Error_Msg_Name_1
:= Chars
(State_Id
);
28940 SPARK_Msg_N
("\use state % instead", N
);
28943 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
28946 -- The constituent appears in the global refinement, but has
28947 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
28949 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
28950 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
28951 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
28953 Error_Msg_Name_1
:= Chars
(State_Id
);
28955 ("constituent & of state % must have mode `Output` in "
28956 & "global refinement", N
, Constit_Id
);
28958 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
28964 ("`Output` state & must be replaced by all its "
28965 & "constituents in global refinement", N
, State_Id
);
28969 ("\constituent & is missing in output list",
28973 Next_Elmt
(Constit_Elmt
);
28976 end Check_Constituent_Usage
;
28980 Item_Elmt
: Elmt_Id
;
28981 Item_Id
: Entity_Id
;
28983 -- Start of processing for Check_Output_States
28986 -- Do not perform this check in an instance because it was already
28987 -- performed successfully in the generic template.
28989 if In_Instance
then
28992 -- Inspect the Output items of the corresponding Global pragma
28993 -- looking for a state with a visible refinement.
28995 elsif Has_Out_State
and then Present
(Out_Items
) then
28996 Item_Elmt
:= First_Elmt
(Out_Items
);
28997 while Present
(Item_Elmt
) loop
28998 Item_Id
:= Node
(Item_Elmt
);
29000 -- When full refinement is visible, ensure that all of the
29001 -- constituents are utilized and they have mode Output. When
29002 -- only partial refinement is visible, ensure that no
29003 -- constituent is utilized.
29005 if Ekind
(Item_Id
) = E_Abstract_State
29006 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
29008 Check_Constituent_Usage
(Item_Id
);
29011 Next_Elmt
(Item_Elmt
);
29014 end Check_Output_States
;
29016 ---------------------------
29017 -- Check_Proof_In_States --
29018 ---------------------------
29020 procedure Check_Proof_In_States
is
29021 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
29022 -- Determine whether at least one constituent of state State_Id with
29023 -- full or partial visible refinement is used and has mode Proof_In.
29024 -- Ensure that the remaining constituents do not have Input, In_Out,
29025 -- or Output modes. Emit an error if this is not the case
29026 -- (SPARK RM 7.2.4(5)).
29028 -----------------------------
29029 -- Check_Constituent_Usage --
29030 -----------------------------
29032 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
29033 Constits
: constant Elist_Id
:=
29034 Partial_Refinement_Constituents
(State_Id
);
29035 Constit_Elmt
: Elmt_Id
;
29036 Constit_Id
: Entity_Id
;
29037 Proof_In_Seen
: Boolean := False;
29040 if Present
(Constits
) then
29041 Constit_Elmt
:= First_Elmt
(Constits
);
29042 while Present
(Constit_Elmt
) loop
29043 Constit_Id
:= Node
(Constit_Elmt
);
29045 -- At least one of the constituents appears as Proof_In
29047 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
29048 Proof_In_Seen
:= True;
29050 -- The constituent appears in the global refinement, but has
29051 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
29053 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
29054 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
29055 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
29057 Error_Msg_Name_1
:= Chars
(State_Id
);
29059 ("constituent & of state % must have mode `Proof_In` "
29060 & "in global refinement", N
, Constit_Id
);
29063 Next_Elmt
(Constit_Elmt
);
29067 -- Not one of the constituents appeared as Proof_In. Always emit
29068 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
29069 -- When only partial refinement is visible, emit an error if the
29070 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
29071 -- the case where both are utilized, an error will be issued by
29072 -- Check_State_And_Constituent_Use.
29074 if not Proof_In_Seen
29075 and then (Has_Visible_Refinement
(State_Id
)
29076 or else Contains
(Repeat_Items
, State_Id
))
29079 ("global refinement of state & must include at least one "
29080 & "constituent of mode `Proof_In`", N
, State_Id
);
29082 end Check_Constituent_Usage
;
29086 Item_Elmt
: Elmt_Id
;
29087 Item_Id
: Entity_Id
;
29089 -- Start of processing for Check_Proof_In_States
29092 -- Do not perform this check in an instance because it was already
29093 -- performed successfully in the generic template.
29095 if In_Instance
then
29098 -- Inspect the Proof_In items of the corresponding Global pragma
29099 -- looking for a state with a visible refinement.
29101 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
29102 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
29103 while Present
(Item_Elmt
) loop
29104 Item_Id
:= Node
(Item_Elmt
);
29106 -- Ensure that at least one of the constituents is utilized
29107 -- and is of mode Proof_In. When only partial refinement is
29108 -- visible, ensure that either one of the constituents is
29109 -- utilized and is of mode Proof_In, or the abstract state
29110 -- is repeated and no constituent is utilized.
29112 if Ekind
(Item_Id
) = E_Abstract_State
29113 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
29115 Check_Constituent_Usage
(Item_Id
);
29118 Next_Elmt
(Item_Elmt
);
29121 end Check_Proof_In_States
;
29123 -------------------------------
29124 -- Check_Refined_Global_List --
29125 -------------------------------
29127 procedure Check_Refined_Global_List
29129 Global_Mode
: Name_Id
:= Name_Input
)
29131 procedure Check_Refined_Global_Item
29133 Global_Mode
: Name_Id
);
29134 -- Verify the legality of a single global item declaration. Parameter
29135 -- Global_Mode denotes the current mode in effect.
29137 -------------------------------
29138 -- Check_Refined_Global_Item --
29139 -------------------------------
29141 procedure Check_Refined_Global_Item
29143 Global_Mode
: Name_Id
)
29145 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
29147 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
29148 -- Issue a common error message for all mode mismatches. Expect
29149 -- denotes the expected mode.
29151 -----------------------------
29152 -- Inconsistent_Mode_Error --
29153 -----------------------------
29155 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
29158 ("global item & has inconsistent modes", Item
, Item_Id
);
29160 Error_Msg_Name_1
:= Global_Mode
;
29161 Error_Msg_Name_2
:= Expect
;
29162 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
29163 end Inconsistent_Mode_Error
;
29167 Enc_State
: Entity_Id
:= Empty
;
29168 -- Encapsulating state for constituent, Empty otherwise
29170 -- Start of processing for Check_Refined_Global_Item
29173 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
29175 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
29178 -- When the state or object acts as a constituent of another
29179 -- state with a visible refinement, collect it for the state
29180 -- completeness checks performed later on. Note that the item
29181 -- acts as a constituent only when the encapsulating state is
29182 -- present in pragma Global.
29184 if Present
(Enc_State
)
29185 and then (Has_Visible_Refinement
(Enc_State
)
29186 or else Has_Partial_Visible_Refinement
(Enc_State
))
29187 and then Contains
(States
, Enc_State
)
29189 -- If the state has only partial visible refinement, remove it
29190 -- from the list of items that should be repeated from pragma
29193 if not Has_Visible_Refinement
(Enc_State
) then
29194 Present_Then_Remove
(Repeat_Items
, Enc_State
);
29197 if Global_Mode
= Name_Input
then
29198 Append_New_Elmt
(Item_Id
, In_Constits
);
29200 elsif Global_Mode
= Name_In_Out
then
29201 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
29203 elsif Global_Mode
= Name_Output
then
29204 Append_New_Elmt
(Item_Id
, Out_Constits
);
29206 elsif Global_Mode
= Name_Proof_In
then
29207 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
29210 -- When not a constituent, ensure that both occurrences of the
29211 -- item in pragmas Global and Refined_Global match. Also remove
29212 -- it when present from the list of items that should be repeated
29213 -- from pragma Global.
29216 Present_Then_Remove
(Repeat_Items
, Item_Id
);
29218 if Contains
(In_Items
, Item_Id
) then
29219 if Global_Mode
/= Name_Input
then
29220 Inconsistent_Mode_Error
(Name_Input
);
29223 elsif Contains
(In_Out_Items
, Item_Id
) then
29224 if Global_Mode
/= Name_In_Out
then
29225 Inconsistent_Mode_Error
(Name_In_Out
);
29228 elsif Contains
(Out_Items
, Item_Id
) then
29229 if Global_Mode
/= Name_Output
then
29230 Inconsistent_Mode_Error
(Name_Output
);
29233 elsif Contains
(Proof_In_Items
, Item_Id
) then
29236 -- The item does not appear in the corresponding Global pragma,
29237 -- it must be an extra (SPARK RM 7.2.4(3)).
29240 pragma Assert
(Present
(Global
));
29241 Error_Msg_Sloc
:= Sloc
(Global
);
29243 ("extra global item & does not refine or repeat any "
29244 & "global item #", Item
, Item_Id
);
29247 end Check_Refined_Global_Item
;
29253 -- Start of processing for Check_Refined_Global_List
29256 -- Do not perform this check in an instance because it was already
29257 -- performed successfully in the generic template.
29259 if In_Instance
then
29262 elsif Nkind
(List
) = N_Null
then
29265 -- Single global item declaration
29267 elsif Nkind
(List
) in N_Expanded_Name
29269 | N_Selected_Component
29271 Check_Refined_Global_Item
(List
, Global_Mode
);
29273 -- Simple global list or moded global list declaration
29275 elsif Nkind
(List
) = N_Aggregate
then
29277 -- The declaration of a simple global list appear as a collection
29280 if Present
(Expressions
(List
)) then
29281 Item
:= First
(Expressions
(List
));
29282 while Present
(Item
) loop
29283 Check_Refined_Global_Item
(Item
, Global_Mode
);
29287 -- The declaration of a moded global list appears as a collection
29288 -- of component associations where individual choices denote
29291 elsif Present
(Component_Associations
(List
)) then
29292 Item
:= First
(Component_Associations
(List
));
29293 while Present
(Item
) loop
29294 Check_Refined_Global_List
29295 (List
=> Expression
(Item
),
29296 Global_Mode
=> Chars
(First
(Choices
(Item
))));
29304 raise Program_Error
;
29310 raise Program_Error
;
29312 end Check_Refined_Global_List
;
29314 --------------------------
29315 -- Collect_Global_Items --
29316 --------------------------
29318 procedure Collect_Global_Items
29320 Mode
: Name_Id
:= Name_Input
)
29322 procedure Collect_Global_Item
29324 Item_Mode
: Name_Id
);
29325 -- Add a single item to the appropriate list. Item_Mode denotes the
29326 -- current mode in effect.
29328 -------------------------
29329 -- Collect_Global_Item --
29330 -------------------------
29332 procedure Collect_Global_Item
29334 Item_Mode
: Name_Id
)
29336 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
29337 -- The above handles abstract views of variables and states built
29338 -- for limited with clauses.
29341 -- Signal that the global list contains at least one abstract
29342 -- state with a visible refinement. Note that the refinement may
29343 -- be null in which case there are no constituents.
29345 if Ekind
(Item_Id
) = E_Abstract_State
then
29346 if Has_Null_Visible_Refinement
(Item_Id
) then
29347 Has_Null_State
:= True;
29349 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
29350 Append_New_Elmt
(Item_Id
, States
);
29352 if Item_Mode
= Name_Input
then
29353 Has_In_State
:= True;
29354 elsif Item_Mode
= Name_In_Out
then
29355 Has_In_Out_State
:= True;
29356 elsif Item_Mode
= Name_Output
then
29357 Has_Out_State
:= True;
29358 elsif Item_Mode
= Name_Proof_In
then
29359 Has_Proof_In_State
:= True;
29364 -- Record global items without full visible refinement found in
29365 -- pragma Global which should be repeated in the global refinement
29366 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
29368 if Ekind
(Item_Id
) /= E_Abstract_State
29369 or else not Has_Visible_Refinement
(Item_Id
)
29371 Append_New_Elmt
(Item_Id
, Repeat_Items
);
29374 -- Add the item to the proper list
29376 if Item_Mode
= Name_Input
then
29377 Append_New_Elmt
(Item_Id
, In_Items
);
29378 elsif Item_Mode
= Name_In_Out
then
29379 Append_New_Elmt
(Item_Id
, In_Out_Items
);
29380 elsif Item_Mode
= Name_Output
then
29381 Append_New_Elmt
(Item_Id
, Out_Items
);
29382 elsif Item_Mode
= Name_Proof_In
then
29383 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
29385 end Collect_Global_Item
;
29391 -- Start of processing for Collect_Global_Items
29394 if Nkind
(List
) = N_Null
then
29397 -- Single global item declaration
29399 elsif Nkind
(List
) in N_Expanded_Name
29401 | N_Selected_Component
29403 Collect_Global_Item
(List
, Mode
);
29405 -- Single global list or moded global list declaration
29407 elsif Nkind
(List
) = N_Aggregate
then
29409 -- The declaration of a simple global list appear as a collection
29412 if Present
(Expressions
(List
)) then
29413 Item
:= First
(Expressions
(List
));
29414 while Present
(Item
) loop
29415 Collect_Global_Item
(Item
, Mode
);
29419 -- The declaration of a moded global list appears as a collection
29420 -- of component associations where individual choices denote mode.
29422 elsif Present
(Component_Associations
(List
)) then
29423 Item
:= First
(Component_Associations
(List
));
29424 while Present
(Item
) loop
29425 Collect_Global_Items
29426 (List
=> Expression
(Item
),
29427 Mode
=> Chars
(First
(Choices
(Item
))));
29435 raise Program_Error
;
29438 -- To accommodate partial decoration of disabled SPARK features, this
29439 -- routine may be called with illegal input. If this is the case, do
29440 -- not raise Program_Error.
29445 end Collect_Global_Items
;
29447 -------------------------
29448 -- Present_Then_Remove --
29449 -------------------------
29451 function Present_Then_Remove
29453 Item
: Entity_Id
) return Boolean
29458 if Present
(List
) then
29459 Elmt
:= First_Elmt
(List
);
29460 while Present
(Elmt
) loop
29461 if Node
(Elmt
) = Item
then
29462 Remove_Elmt
(List
, Elmt
);
29471 end Present_Then_Remove
;
29473 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
29476 Ignore
:= Present_Then_Remove
(List
, Item
);
29477 end Present_Then_Remove
;
29479 -------------------------------
29480 -- Report_Extra_Constituents --
29481 -------------------------------
29483 procedure Report_Extra_Constituents
is
29484 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
29485 -- Emit an error for every element of List
29487 ---------------------------------------
29488 -- Report_Extra_Constituents_In_List --
29489 ---------------------------------------
29491 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
29492 Constit_Elmt
: Elmt_Id
;
29495 if Present
(List
) then
29496 Constit_Elmt
:= First_Elmt
(List
);
29497 while Present
(Constit_Elmt
) loop
29498 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
29499 Next_Elmt
(Constit_Elmt
);
29502 end Report_Extra_Constituents_In_List
;
29504 -- Start of processing for Report_Extra_Constituents
29507 -- Do not perform this check in an instance because it was already
29508 -- performed successfully in the generic template.
29510 if In_Instance
then
29514 Report_Extra_Constituents_In_List
(In_Constits
);
29515 Report_Extra_Constituents_In_List
(In_Out_Constits
);
29516 Report_Extra_Constituents_In_List
(Out_Constits
);
29517 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
29519 end Report_Extra_Constituents
;
29521 --------------------------
29522 -- Report_Missing_Items --
29523 --------------------------
29525 procedure Report_Missing_Items
is
29526 Item_Elmt
: Elmt_Id
;
29527 Item_Id
: Entity_Id
;
29530 -- Do not perform this check in an instance because it was already
29531 -- performed successfully in the generic template.
29533 if In_Instance
then
29537 if Present
(Repeat_Items
) then
29538 Item_Elmt
:= First_Elmt
(Repeat_Items
);
29539 while Present
(Item_Elmt
) loop
29540 Item_Id
:= Node
(Item_Elmt
);
29541 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
29542 Next_Elmt
(Item_Elmt
);
29546 end Report_Missing_Items
;
29550 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29551 Errors
: constant Nat
:= Serious_Errors_Detected
;
29553 No_Constit
: Boolean;
29555 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
29558 -- Do not analyze the pragma multiple times
29560 if Is_Analyzed_Pragma
(N
) then
29564 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
29566 -- Use the anonymous object as the proper spec when Refined_Global
29567 -- applies to the body of a single task type. The object carries the
29568 -- proper Chars as well as all non-refined versions of pragmas.
29570 if Is_Single_Concurrent_Type
(Spec_Id
) then
29571 Spec_Id
:= Anonymous_Object
(Spec_Id
);
29574 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
29575 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
29577 -- The subprogram declaration lacks pragma Global. This renders
29578 -- Refined_Global useless as there is nothing to refine.
29580 if No
(Global
) then
29582 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
29583 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
29587 -- Extract all relevant items from the corresponding Global pragma
29589 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
29591 -- Package and subprogram bodies are instantiated individually in
29592 -- a separate compiler pass. Due to this mode of instantiation, the
29593 -- refinement of a state may no longer be visible when a subprogram
29594 -- body contract is instantiated. Since the generic template is legal,
29595 -- do not perform this check in the instance to circumvent this oddity.
29597 if In_Instance
then
29600 -- Non-instance case
29603 -- The corresponding Global pragma must mention at least one
29604 -- state with a visible refinement at the point Refined_Global
29605 -- is processed. States with null refinements need Refined_Global
29606 -- pragma (SPARK RM 7.2.4(2)).
29608 if not Has_In_State
29609 and then not Has_In_Out_State
29610 and then not Has_Out_State
29611 and then not Has_Proof_In_State
29612 and then not Has_Null_State
29615 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
29616 & "depend on abstract state with visible refinement"),
29620 -- The global refinement of inputs and outputs cannot be null when
29621 -- the corresponding Global pragma contains at least one item except
29622 -- in the case where we have states with null refinements.
29624 elsif Nkind
(Items
) = N_Null
29626 (Present
(In_Items
)
29627 or else Present
(In_Out_Items
)
29628 or else Present
(Out_Items
)
29629 or else Present
(Proof_In_Items
))
29630 and then not Has_Null_State
29633 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
29634 & "global items"), N
, Spec_Id
);
29639 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
29640 -- This ensures that the categorization of all refined global items is
29641 -- consistent with their role.
29643 Analyze_Global_In_Decl_Part
(N
);
29645 -- Perform all refinement checks with respect to completeness and mode
29648 if Serious_Errors_Detected
= Errors
then
29649 Check_Refined_Global_List
(Items
);
29652 -- Store the information that no constituent is used in the global
29653 -- refinement, prior to calling checking procedures which remove items
29654 -- from the list of constituents.
29658 and then No
(In_Out_Constits
)
29659 and then No
(Out_Constits
)
29660 and then No
(Proof_In_Constits
);
29662 -- For Input states with visible refinement, at least one constituent
29663 -- must be used as an Input in the global refinement.
29665 if Serious_Errors_Detected
= Errors
then
29666 Check_Input_States
;
29669 -- Verify all possible completion variants for In_Out states with
29670 -- visible refinement.
29672 if Serious_Errors_Detected
= Errors
then
29673 Check_In_Out_States
;
29676 -- For Output states with visible refinement, all constituents must be
29677 -- used as Outputs in the global refinement.
29679 if Serious_Errors_Detected
= Errors
then
29680 Check_Output_States
;
29683 -- For Proof_In states with visible refinement, at least one constituent
29684 -- must be used as Proof_In in the global refinement.
29686 if Serious_Errors_Detected
= Errors
then
29687 Check_Proof_In_States
;
29690 -- Emit errors for all constituents that belong to other states with
29691 -- visible refinement that do not appear in Global.
29693 if Serious_Errors_Detected
= Errors
then
29694 Report_Extra_Constituents
;
29697 -- Emit errors for all items in Global that are not repeated in the
29698 -- global refinement and for which there is no full visible refinement
29699 -- and, in the case of states with partial visible refinement, no
29700 -- constituent is mentioned in the global refinement.
29702 if Serious_Errors_Detected
= Errors
then
29703 Report_Missing_Items
;
29706 -- Emit an error if no constituent is used in the global refinement
29707 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
29708 -- one may be issued by the checking procedures. Do not perform this
29709 -- check in an instance because it was already performed successfully
29710 -- in the generic template.
29712 if Serious_Errors_Detected
= Errors
29713 and then not In_Instance
29714 and then not Has_Null_State
29715 and then No_Constit
29717 SPARK_Msg_N
("missing refinement", N
);
29721 Set_Is_Analyzed_Pragma
(N
);
29722 end Analyze_Refined_Global_In_Decl_Part
;
29724 ----------------------------------------
29725 -- Analyze_Refined_State_In_Decl_Part --
29726 ----------------------------------------
29728 procedure Analyze_Refined_State_In_Decl_Part
29730 Freeze_Id
: Entity_Id
:= Empty
)
29732 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
29733 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
29734 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
29736 Available_States
: Elist_Id
:= No_Elist
;
29737 -- A list of all abstract states defined in the package declaration that
29738 -- are available for refinement. The list is used to report unrefined
29741 Body_States
: Elist_Id
:= No_Elist
;
29742 -- A list of all hidden states that appear in the body of the related
29743 -- package. The list is used to report unused hidden states.
29745 Constituents_Seen
: Elist_Id
:= No_Elist
;
29746 -- A list that contains all constituents processed so far. The list is
29747 -- used to detect multiple uses of the same constituent.
29749 Freeze_Posted
: Boolean := False;
29750 -- A flag that controls the output of a freezing-related error (see use
29753 Refined_States_Seen
: Elist_Id
:= No_Elist
;
29754 -- A list that contains all refined states processed so far. The list is
29755 -- used to detect duplicate refinements.
29757 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
29758 -- Perform full analysis of a single refinement clause
29760 procedure Report_Unrefined_States
(States
: Elist_Id
);
29761 -- Emit errors for all unrefined abstract states found in list States
29763 -------------------------------
29764 -- Analyze_Refinement_Clause --
29765 -------------------------------
29767 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
29768 AR_Constit
: Entity_Id
:= Empty
;
29769 AW_Constit
: Entity_Id
:= Empty
;
29770 ER_Constit
: Entity_Id
:= Empty
;
29771 EW_Constit
: Entity_Id
:= Empty
;
29772 -- The entities of external constituents that contain one of the
29773 -- following enabled properties: Async_Readers, Async_Writers,
29774 -- Effective_Reads and Effective_Writes.
29776 External_Constit_Seen
: Boolean := False;
29777 -- Flag used to mark when at least one external constituent is part
29778 -- of the state refinement.
29780 Non_Null_Seen
: Boolean := False;
29781 Null_Seen
: Boolean := False;
29782 -- Flags used to detect multiple uses of null in a single clause or a
29783 -- mixture of null and non-null constituents.
29785 Part_Of_Constits
: Elist_Id
:= No_Elist
;
29786 -- A list of all candidate constituents subject to indicator Part_Of
29787 -- where the encapsulating state is the current state.
29790 State_Id
: Entity_Id
;
29791 -- The current state being refined
29793 procedure Analyze_Constituent
(Constit
: Node_Id
);
29794 -- Perform full analysis of a single constituent
29796 procedure Check_External_Property
29797 (Prop_Nam
: Name_Id
;
29799 Constit
: Entity_Id
);
29800 -- Determine whether a property denoted by name Prop_Nam is present
29801 -- in the refined state. Emit an error if this is not the case. Flag
29802 -- Enabled should be set when the property applies to the refined
29803 -- state. Constit denotes the constituent (if any) which introduces
29804 -- the property in the refinement.
29806 procedure Match_State
;
29807 -- Determine whether the state being refined appears in list
29808 -- Available_States. Emit an error when attempting to re-refine the
29809 -- state or when the state is not defined in the package declaration,
29810 -- otherwise remove the state from Available_States.
29812 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
29813 -- Emit errors for all unused Part_Of constituents in list Constits
29815 -------------------------
29816 -- Analyze_Constituent --
29817 -------------------------
29819 procedure Analyze_Constituent
(Constit
: Node_Id
) is
29820 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
29821 -- Determine whether constituent Constit denoted by its entity
29822 -- Constit_Id appears in Body_States. Emit an error when the
29823 -- constituent is not a valid hidden state of the related package
29824 -- or when it is used more than once. Otherwise remove the
29825 -- constituent from Body_States.
29827 -----------------------
29828 -- Match_Constituent --
29829 -----------------------
29831 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
29832 procedure Collect_Constituent
;
29833 -- Verify the legality of constituent Constit_Id and add it to
29834 -- the refinements of State_Id.
29836 -------------------------
29837 -- Collect_Constituent --
29838 -------------------------
29840 procedure Collect_Constituent
is
29841 Constits
: Elist_Id
;
29844 -- The Ghost policy in effect at the point of abstract state
29845 -- declaration and constituent must match (SPARK RM 6.9(15))
29847 Check_Ghost_Refinement
29848 (State
, State_Id
, Constit
, Constit_Id
);
29850 -- A synchronized state must be refined by a synchronized
29851 -- object or another synchronized state (SPARK RM 9.6).
29853 if Is_Synchronized_State
(State_Id
)
29854 and then not Is_Synchronized_Object
(Constit_Id
)
29855 and then not Is_Synchronized_State
(Constit_Id
)
29858 ("constituent of synchronized state & must be "
29859 & "synchronized", Constit
, State_Id
);
29862 -- Add the constituent to the list of processed items to aid
29863 -- with the detection of duplicates.
29865 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
29867 -- Collect the constituent in the list of refinement items
29868 -- and establish a relation between the refined state and
29871 Constits
:= Refinement_Constituents
(State_Id
);
29873 if No
(Constits
) then
29874 Constits
:= New_Elmt_List
;
29875 Set_Refinement_Constituents
(State_Id
, Constits
);
29878 Append_Elmt
(Constit_Id
, Constits
);
29879 Set_Encapsulating_State
(Constit_Id
, State_Id
);
29881 -- The state has at least one legal constituent, mark the
29882 -- start of the refinement region. The region ends when the
29883 -- body declarations end (see routine Analyze_Declarations).
29885 Set_Has_Visible_Refinement
(State_Id
);
29887 -- When the constituent is external, save its relevant
29888 -- property for further checks.
29890 if Async_Readers_Enabled
(Constit_Id
) then
29891 AR_Constit
:= Constit_Id
;
29892 External_Constit_Seen
:= True;
29895 if Async_Writers_Enabled
(Constit_Id
) then
29896 AW_Constit
:= Constit_Id
;
29897 External_Constit_Seen
:= True;
29900 if Effective_Reads_Enabled
(Constit_Id
) then
29901 ER_Constit
:= Constit_Id
;
29902 External_Constit_Seen
:= True;
29905 if Effective_Writes_Enabled
(Constit_Id
) then
29906 EW_Constit
:= Constit_Id
;
29907 External_Constit_Seen
:= True;
29909 end Collect_Constituent
;
29913 State_Elmt
: Elmt_Id
;
29915 -- Start of processing for Match_Constituent
29918 -- Detect a duplicate use of a constituent
29920 if Contains
(Constituents_Seen
, Constit_Id
) then
29922 ("duplicate use of constituent &", Constit
, Constit_Id
);
29926 -- The constituent is subject to a Part_Of indicator
29928 if Present
(Encapsulating_State
(Constit_Id
)) then
29929 if Encapsulating_State
(Constit_Id
) = State_Id
then
29930 Remove
(Part_Of_Constits
, Constit_Id
);
29931 Collect_Constituent
;
29933 -- The constituent is part of another state and is used
29934 -- incorrectly in the refinement of the current state.
29937 Error_Msg_Name_1
:= Chars
(State_Id
);
29939 ("& cannot act as constituent of state %",
29940 Constit
, Constit_Id
);
29942 ("\Part_Of indicator specifies encapsulator &",
29943 Constit
, Encapsulating_State
(Constit_Id
));
29948 Pack_Id
: Entity_Id
;
29949 Placement
: State_Space_Kind
;
29951 -- Find where the constituent lives with respect to the
29954 Find_Placement_In_State_Space
29955 (Item_Id
=> Constit_Id
,
29956 Placement
=> Placement
,
29957 Pack_Id
=> Pack_Id
);
29959 -- The constituent is either part of the hidden state of
29960 -- the package or part of the visible state of a private
29961 -- child package, but lacks a Part_Of indicator.
29963 if (Placement
= Private_State_Space
29964 and then Pack_Id
= Spec_Id
)
29966 (Placement
= Visible_State_Space
29967 and then Is_Child_Unit
(Pack_Id
)
29968 and then not Is_Generic_Unit
(Pack_Id
)
29969 and then Is_Private_Descendant
(Pack_Id
))
29971 Error_Msg_Name_1
:= Chars
(State_Id
);
29973 ("& cannot act as constituent of state %",
29974 Constit
, Constit_Id
);
29976 Sloc
(Enclosing_Declaration
(Constit_Id
));
29978 ("\missing Part_Of indicator # should specify "
29979 & "encapsulator &",
29980 Constit
, State_Id
);
29982 -- The only other source of legal constituents is the
29983 -- body state space of the related package.
29986 if Present
(Body_States
) then
29987 State_Elmt
:= First_Elmt
(Body_States
);
29988 while Present
(State_Elmt
) loop
29990 -- Consume a valid constituent to signal that it
29991 -- has been encountered.
29993 if Node
(State_Elmt
) = Constit_Id
then
29994 Remove_Elmt
(Body_States
, State_Elmt
);
29995 Collect_Constituent
;
29999 Next_Elmt
(State_Elmt
);
30003 -- At this point it is known that the constituent is
30004 -- not part of the package hidden state and cannot be
30005 -- used in a refinement (SPARK RM 7.2.2(9)).
30007 Error_Msg_Name_1
:= Chars
(Spec_Id
);
30009 ("cannot use & in refinement, constituent is not a "
30010 & "hidden state of package %", Constit
, Constit_Id
);
30014 end Match_Constituent
;
30018 Constit_Id
: Entity_Id
;
30019 Constits
: Elist_Id
;
30021 -- Start of processing for Analyze_Constituent
30024 -- Detect multiple uses of null in a single refinement clause or a
30025 -- mixture of null and non-null constituents.
30027 if Nkind
(Constit
) = N_Null
then
30030 ("multiple null constituents not allowed", Constit
);
30032 elsif Non_Null_Seen
then
30034 ("cannot mix null and non-null constituents", Constit
);
30039 -- Collect the constituent in the list of refinement items
30041 Constits
:= Refinement_Constituents
(State_Id
);
30043 if No
(Constits
) then
30044 Constits
:= New_Elmt_List
;
30045 Set_Refinement_Constituents
(State_Id
, Constits
);
30048 Append_Elmt
(Constit
, Constits
);
30050 -- The state has at least one legal constituent, mark the
30051 -- start of the refinement region. The region ends when the
30052 -- body declarations end (see Analyze_Declarations).
30054 Set_Has_Visible_Refinement
(State_Id
);
30057 -- Non-null constituents
30060 Non_Null_Seen
:= True;
30064 ("cannot mix null and non-null constituents", Constit
);
30068 Resolve_State
(Constit
);
30070 -- Ensure that the constituent denotes a valid state or a
30071 -- whole object (SPARK RM 7.2.2(5)).
30073 if Is_Entity_Name
(Constit
) then
30074 Constit_Id
:= Entity_Of
(Constit
);
30076 -- When a constituent is declared after a subprogram body
30077 -- that caused freezing of the related contract where
30078 -- pragma Refined_State resides, the constituent appears
30079 -- undefined and carries Any_Id as its entity.
30081 -- package body Pack
30082 -- with Refined_State => (State => Constit)
30085 -- with Refined_Global => (Input => Constit)
30093 if Constit_Id
= Any_Id
then
30094 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
30096 -- Emit a specialized info message when the contract of
30097 -- the related package body was "frozen" by another body.
30098 -- Note that it is not possible to precisely identify why
30099 -- the constituent is undefined because it is not visible
30100 -- when pragma Refined_State is analyzed. This message is
30101 -- a reasonable approximation.
30103 if Present
(Freeze_Id
) and then not Freeze_Posted
then
30104 Freeze_Posted
:= True;
30106 Error_Msg_Name_1
:= Chars
(Body_Id
);
30107 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30109 ("body & declared # freezes the contract of %",
30112 ("\all constituents must be declared before body #",
30115 -- A misplaced constituent is a critical error because
30116 -- pragma Refined_Depends or Refined_Global depends on
30117 -- the proper link between a state and a constituent.
30118 -- Stop the compilation, as this leads to a multitude
30119 -- of misleading cascaded errors.
30121 raise Unrecoverable_Error
;
30124 -- The constituent is a valid state or object
30126 elsif Ekind
(Constit_Id
) in
30127 E_Abstract_State | E_Constant | E_Variable
30129 Match_Constituent
(Constit_Id
);
30131 -- The variable may eventually become a constituent of a
30132 -- single protected/task type. Record the reference now
30133 -- and verify its legality when analyzing the contract of
30134 -- the variable (SPARK RM 9.3).
30136 if Ekind
(Constit_Id
) = E_Variable
then
30137 Record_Possible_Part_Of_Reference
30138 (Var_Id
=> Constit_Id
,
30142 -- Otherwise the constituent is illegal
30146 ("constituent & must denote object or state",
30147 Constit
, Constit_Id
);
30150 -- The constituent is illegal
30153 SPARK_Msg_N
("malformed constituent", Constit
);
30156 end Analyze_Constituent
;
30158 -----------------------------
30159 -- Check_External_Property --
30160 -----------------------------
30162 procedure Check_External_Property
30163 (Prop_Nam
: Name_Id
;
30165 Constit
: Entity_Id
)
30168 -- The property is missing in the declaration of the state, but
30169 -- a constituent is introducing it in the state refinement
30170 -- (SPARK RM 7.2.8(2)).
30172 if not Enabled
and then Present
(Constit
) then
30173 Error_Msg_Name_1
:= Prop_Nam
;
30174 Error_Msg_Name_2
:= Chars
(State_Id
);
30176 ("constituent & introduces external property % in refinement "
30177 & "of state %", State
, Constit
);
30179 Error_Msg_Sloc
:= Sloc
(State_Id
);
30181 ("\property is missing in abstract state declaration #",
30184 end Check_External_Property
;
30190 procedure Match_State
is
30191 State_Elmt
: Elmt_Id
;
30194 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
30196 if Contains
(Refined_States_Seen
, State_Id
) then
30198 ("duplicate refinement of state &", State
, State_Id
);
30202 -- Inspect the abstract states defined in the package declaration
30203 -- looking for a match.
30205 State_Elmt
:= First_Elmt
(Available_States
);
30206 while Present
(State_Elmt
) loop
30208 -- A valid abstract state is being refined in the body. Add
30209 -- the state to the list of processed refined states to aid
30210 -- with the detection of duplicate refinements. Remove the
30211 -- state from Available_States to signal that it has already
30214 if Node
(State_Elmt
) = State_Id
then
30215 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
30216 Remove_Elmt
(Available_States
, State_Elmt
);
30220 Next_Elmt
(State_Elmt
);
30223 -- If we get here, we are refining a state that is not defined in
30224 -- the package declaration.
30226 Error_Msg_Name_1
:= Chars
(Spec_Id
);
30228 ("cannot refine state, & is not defined in package %",
30232 --------------------------------
30233 -- Report_Unused_Constituents --
30234 --------------------------------
30236 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
30237 Constit_Elmt
: Elmt_Id
;
30238 Constit_Id
: Entity_Id
;
30239 Posted
: Boolean := False;
30242 if Present
(Constits
) then
30243 Constit_Elmt
:= First_Elmt
(Constits
);
30244 while Present
(Constit_Elmt
) loop
30245 Constit_Id
:= Node
(Constit_Elmt
);
30247 -- Generate an error message of the form:
30249 -- state ... has unused Part_Of constituents
30250 -- abstract state ... defined at ...
30251 -- constant ... defined at ...
30252 -- variable ... defined at ...
30257 ("state & has unused Part_Of constituents",
30261 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
30263 if Ekind
(Constit_Id
) = E_Abstract_State
then
30265 ("\abstract state & defined #", State
, Constit_Id
);
30267 elsif Ekind
(Constit_Id
) = E_Constant
then
30269 ("\constant & defined #", State
, Constit_Id
);
30272 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
30273 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
30276 Next_Elmt
(Constit_Elmt
);
30279 end Report_Unused_Constituents
;
30281 -- Local declarations
30283 Body_Ref
: Node_Id
;
30284 Body_Ref_Elmt
: Elmt_Id
;
30286 Extra_State
: Node_Id
;
30288 -- Start of processing for Analyze_Refinement_Clause
30291 -- A refinement clause appears as a component association where the
30292 -- sole choice is the state and the expressions are the constituents.
30293 -- This is a syntax error, always report.
30295 if Nkind
(Clause
) /= N_Component_Association
then
30296 Error_Msg_N
("malformed state refinement clause", Clause
);
30300 -- Analyze the state name of a refinement clause
30302 State
:= First
(Choices
(Clause
));
30305 Resolve_State
(State
);
30307 -- Ensure that the state name denotes a valid abstract state that is
30308 -- defined in the spec of the related package.
30310 if Is_Entity_Name
(State
) then
30311 State_Id
:= Entity_Of
(State
);
30313 -- When the abstract state is undefined, it appears as Any_Id. Do
30314 -- not continue with the analysis of the clause.
30316 if State_Id
= Any_Id
then
30319 -- Catch any attempts to re-refine a state or refine a state that
30320 -- is not defined in the package declaration.
30322 elsif Ekind
(State_Id
) = E_Abstract_State
then
30326 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
30330 -- References to a state with visible refinement are illegal.
30331 -- When nested packages are involved, detecting such references is
30332 -- tricky because pragma Refined_State is analyzed later than the
30333 -- offending pragma Depends or Global. References that occur in
30334 -- such nested context are stored in a list. Emit errors for all
30335 -- references found in Body_References (SPARK RM 6.1.4(8)).
30337 if Present
(Body_References
(State_Id
)) then
30338 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
30339 while Present
(Body_Ref_Elmt
) loop
30340 Body_Ref
:= Node
(Body_Ref_Elmt
);
30342 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
30343 Error_Msg_Sloc
:= Sloc
(State
);
30344 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
30346 Next_Elmt
(Body_Ref_Elmt
);
30350 -- The state name is illegal. This is a syntax error, always report.
30353 Error_Msg_N
("malformed state name in refinement clause", State
);
30357 -- A refinement clause may only refine one state at a time
30359 Extra_State
:= Next
(State
);
30361 if Present
(Extra_State
) then
30363 ("refinement clause cannot cover multiple states", Extra_State
);
30366 -- Replicate the Part_Of constituents of the refined state because
30367 -- the algorithm will consume items.
30369 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
30371 -- Analyze all constituents of the refinement. Multiple constituents
30372 -- appear as an aggregate.
30374 Constit
:= Expression
(Clause
);
30376 if Nkind
(Constit
) = N_Aggregate
then
30377 if Present
(Component_Associations
(Constit
)) then
30379 ("constituents of refinement clause must appear in "
30380 & "positional form", Constit
);
30382 else pragma Assert
(Present
(Expressions
(Constit
)));
30383 Constit
:= First
(Expressions
(Constit
));
30384 while Present
(Constit
) loop
30385 Analyze_Constituent
(Constit
);
30390 -- Various forms of a single constituent. Note that these may include
30391 -- malformed constituents.
30394 Analyze_Constituent
(Constit
);
30397 -- Verify that external constituents do not introduce new external
30398 -- property in the state refinement (SPARK RM 7.2.8(2)).
30400 if Is_External_State
(State_Id
) then
30401 Check_External_Property
30402 (Prop_Nam
=> Name_Async_Readers
,
30403 Enabled
=> Async_Readers_Enabled
(State_Id
),
30404 Constit
=> AR_Constit
);
30406 Check_External_Property
30407 (Prop_Nam
=> Name_Async_Writers
,
30408 Enabled
=> Async_Writers_Enabled
(State_Id
),
30409 Constit
=> AW_Constit
);
30411 Check_External_Property
30412 (Prop_Nam
=> Name_Effective_Reads
,
30413 Enabled
=> Effective_Reads_Enabled
(State_Id
),
30414 Constit
=> ER_Constit
);
30416 Check_External_Property
30417 (Prop_Nam
=> Name_Effective_Writes
,
30418 Enabled
=> Effective_Writes_Enabled
(State_Id
),
30419 Constit
=> EW_Constit
);
30421 -- When a refined state is not external, it should not have external
30422 -- constituents (SPARK RM 7.2.8(1)).
30424 elsif External_Constit_Seen
then
30426 ("non-external state & cannot contain external constituents in "
30427 & "refinement", State
, State_Id
);
30430 -- Ensure that all Part_Of candidate constituents have been mentioned
30431 -- in the refinement clause.
30433 Report_Unused_Constituents
(Part_Of_Constits
);
30435 -- Avoid a cascading error reporting a missing refinement by adding a
30436 -- dummy constituent.
30438 if No
(Refinement_Constituents
(State_Id
)) then
30439 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
(Any_Id
));
30442 -- At this point the refinement might be dummy, but must be
30443 -- well-formed, to prevent cascaded errors.
30445 pragma Assert
(Has_Null_Refinement
(State_Id
)
30447 Has_Non_Null_Refinement
(State_Id
));
30448 end Analyze_Refinement_Clause
;
30450 -----------------------------
30451 -- Report_Unrefined_States --
30452 -----------------------------
30454 procedure Report_Unrefined_States
(States
: Elist_Id
) is
30455 State_Elmt
: Elmt_Id
;
30458 if Present
(States
) then
30459 State_Elmt
:= First_Elmt
(States
);
30460 while Present
(State_Elmt
) loop
30462 ("abstract state & must be refined", Node
(State_Elmt
));
30464 Next_Elmt
(State_Elmt
);
30467 end Report_Unrefined_States
;
30469 -- Local declarations
30471 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
30474 -- Start of processing for Analyze_Refined_State_In_Decl_Part
30477 -- Do not analyze the pragma multiple times
30479 if Is_Analyzed_Pragma
(N
) then
30483 -- Save the scenario for examination by the ABE Processing phase
30485 Record_Elaboration_Scenario
(N
);
30487 -- Replicate the abstract states declared by the package because the
30488 -- matching algorithm will consume states.
30490 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
30492 -- Gather all abstract states and objects declared in the visible
30493 -- state space of the package body. These items must be utilized as
30494 -- constituents in a state refinement.
30496 Body_States
:= Collect_Body_States
(Body_Id
);
30498 -- Multiple non-null state refinements appear as an aggregate
30500 if Nkind
(Clauses
) = N_Aggregate
then
30501 if Present
(Expressions
(Clauses
)) then
30503 ("state refinements must appear as component associations",
30506 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
30507 Clause
:= First
(Component_Associations
(Clauses
));
30508 while Present
(Clause
) loop
30509 Analyze_Refinement_Clause
(Clause
);
30514 -- Various forms of a single state refinement. Note that these may
30515 -- include malformed refinements.
30518 Analyze_Refinement_Clause
(Clauses
);
30521 -- List all abstract states that were left unrefined
30523 Report_Unrefined_States
(Available_States
);
30525 Set_Is_Analyzed_Pragma
(N
);
30526 end Analyze_Refined_State_In_Decl_Part
;
30528 ---------------------------------------------
30529 -- Analyze_Subprogram_Variant_In_Decl_Part --
30530 ---------------------------------------------
30532 -- WARNING: This routine manages Ghost regions. Return statements must be
30533 -- replaced by gotos which jump to the end of the routine and restore the
30536 procedure Analyze_Subprogram_Variant_In_Decl_Part
30538 Freeze_Id
: Entity_Id
:= Empty
)
30540 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
30541 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30543 procedure Analyze_Variant
(Variant
: Node_Id
);
30544 -- Verify the legality of a single contract case
30546 ---------------------
30547 -- Analyze_Variant --
30548 ---------------------
30550 procedure Analyze_Variant
(Variant
: Node_Id
) is
30551 Direction
: Node_Id
;
30554 Extra_Direction
: Node_Id
;
30557 if Nkind
(Variant
) /= N_Component_Association
then
30558 Error_Msg_N
("wrong syntax in subprogram variant", Variant
);
30562 Direction
:= First
(Choices
(Variant
));
30563 Expr
:= Expression
(Variant
);
30565 -- Each variant must have exactly one direction
30567 Extra_Direction
:= Next
(Direction
);
30569 if Present
(Extra_Direction
) then
30571 ("subprogram variant case must have exactly one direction",
30575 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
30577 if Nkind
(Direction
) = N_Identifier
then
30578 if Chars
(Direction
) not in Name_Decreases
30582 Error_Msg_N
("wrong direction", Direction
);
30585 Error_Msg_N
("wrong syntax", Direction
);
30588 Errors
:= Serious_Errors_Detected
;
30590 -- Preanalyze_Assert_Expression, but without enforcing any of the two
30591 -- acceptable types.
30593 Preanalyze_Assert_Expression
(Expr
);
30595 -- Expression of a discrete type is allowed. Nothing more to check
30596 -- for structural variants.
30598 if Is_Discrete_Type
(Etype
(Expr
))
30599 or else Chars
(Direction
) = Name_Structural
30603 -- Expression of a Big_Integer type (or its ghost variant) is only
30604 -- allowed in Decreases clause.
30607 Is_RTE
(Base_Type
(Etype
(Expr
)), RE_Big_Integer
)
30609 Is_RTE
(Base_Type
(Etype
(Expr
)), RO_GH_Big_Integer
)
30611 if Chars
(Direction
) = Name_Increases
then
30613 ("Subprogram_Variant with Big_Integer can only decrease",
30617 -- Expression of other types is not allowed
30620 Error_Msg_N
("expected a discrete or Big_Integer type", Expr
);
30623 -- Emit a clarification message when the variant expression
30624 -- contains at least one undefined reference, possibly due
30625 -- to contract freezing.
30627 if Errors
/= Serious_Errors_Detected
30628 and then Present
(Freeze_Id
)
30629 and then Has_Undefined_Reference
(Expr
)
30631 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
30633 end Analyze_Variant
;
30637 Variants
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
30639 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
30640 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
30641 -- Save the Ghost-related attributes to restore on exit
30644 Restore_Scope
: Boolean := False;
30646 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
30649 -- Do not analyze the pragma multiple times
30651 if Is_Analyzed_Pragma
(N
) then
30655 -- Set the Ghost mode in effect from the pragma. Due to the delayed
30656 -- analysis of the pragma, the Ghost mode at point of declaration and
30657 -- point of analysis may not necessarily be the same. Use the mode in
30658 -- effect at the point of declaration.
30660 Set_Ghost_Mode
(N
);
30662 -- Single and multiple contract cases must appear in aggregate form. If
30663 -- this is not the case, then either the parser of the analysis of the
30664 -- pragma failed to produce an aggregate, e.g. when the contract is
30665 -- "null" or a "(null record)".
30668 (if Nkind
(Variants
) = N_Aggregate
30669 then Null_Record_Present
(Variants
)
30670 xor (Present
(Component_Associations
(Variants
))
30672 Present
(Expressions
(Variants
)))
30673 else Nkind
(Variants
) = N_Null
);
30675 -- Only "change_direction => discrete_expression" clauses are allowed
30677 if Nkind
(Variants
) = N_Aggregate
30678 and then Present
(Component_Associations
(Variants
))
30679 and then No
(Expressions
(Variants
))
30682 -- Check that the expression is a proper aggregate (no parentheses)
30684 if Paren_Count
(Variants
) /= 0 then
30685 Error_Msg_F
-- CODEFIX
30686 ("redundant parentheses", Variants
);
30689 -- Ensure that the formal parameters are visible when analyzing all
30690 -- clauses. This falls out of the general rule of aspects pertaining
30691 -- to subprogram declarations.
30693 if not In_Open_Scopes
(Spec_Id
) then
30694 Restore_Scope
:= True;
30695 Push_Scope
(Spec_Id
);
30697 if Is_Generic_Subprogram
(Spec_Id
) then
30698 Install_Generic_Formals
(Spec_Id
);
30700 Install_Formals
(Spec_Id
);
30704 Variant
:= First
(Component_Associations
(Variants
));
30705 while Present
(Variant
) loop
30706 Analyze_Variant
(Variant
);
30708 if Chars
(First
(Choices
(Variant
))) = Name_Structural
30709 and then List_Length
(Component_Associations
(Variants
)) > 1
30712 ("Structural variant shall be the only variant", Variant
);
30718 if Restore_Scope
then
30722 -- Currently it is not possible to inline Subprogram_Variant on a
30723 -- subprogram subject to pragma Inline_Always.
30725 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
30727 -- Otherwise the pragma is illegal
30730 Error_Msg_N
("wrong syntax for subprogram variant", N
);
30733 Set_Is_Analyzed_Pragma
(N
);
30735 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
30736 end Analyze_Subprogram_Variant_In_Decl_Part
;
30738 ------------------------------------
30739 -- Analyze_Test_Case_In_Decl_Part --
30740 ------------------------------------
30742 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
30743 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
30744 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30746 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
30747 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
30748 -- denoted by Arg_Nam.
30750 ------------------------------
30751 -- Preanalyze_Test_Case_Arg --
30752 ------------------------------
30754 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
30758 -- Preanalyze the original aspect argument for a generic subprogram
30759 -- to properly capture global references.
30761 if Is_Generic_Subprogram
(Spec_Id
) then
30765 Arg_Nam
=> Arg_Nam
,
30766 From_Aspect
=> True);
30768 if Present
(Arg
) then
30769 Preanalyze_Assert_Expression
30770 (Expression
(Arg
), Standard_Boolean
);
30774 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
30776 if Present
(Arg
) then
30777 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
30779 end Preanalyze_Test_Case_Arg
;
30783 Restore_Scope
: Boolean := False;
30785 -- Start of processing for Analyze_Test_Case_In_Decl_Part
30788 -- Do not analyze the pragma multiple times
30790 if Is_Analyzed_Pragma
(N
) then
30794 -- Ensure that the formal parameters are visible when analyzing all
30795 -- clauses. This falls out of the general rule of aspects pertaining
30796 -- to subprogram declarations.
30798 if not In_Open_Scopes
(Spec_Id
) then
30799 Restore_Scope
:= True;
30800 Push_Scope
(Spec_Id
);
30802 if Is_Generic_Subprogram
(Spec_Id
) then
30803 Install_Generic_Formals
(Spec_Id
);
30805 Install_Formals
(Spec_Id
);
30809 Preanalyze_Test_Case_Arg
(Name_Requires
);
30810 Preanalyze_Test_Case_Arg
(Name_Ensures
);
30812 if Restore_Scope
then
30816 -- Currently it is not possible to inline pre/postconditions on a
30817 -- subprogram subject to pragma Inline_Always.
30819 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
30821 Set_Is_Analyzed_Pragma
(N
);
30822 end Analyze_Test_Case_In_Decl_Part
;
30828 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
30833 if Present
(List
) then
30834 Elmt
:= First_Elmt
(List
);
30835 while Present
(Elmt
) loop
30836 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
30839 Id
:= Entity_Of
(Node
(Elmt
));
30842 if Id
= Item_Id
then
30853 -----------------------------------
30854 -- Build_Pragma_Check_Equivalent --
30855 -----------------------------------
30857 function Build_Pragma_Check_Equivalent
30859 Subp_Id
: Entity_Id
:= Empty
;
30860 Inher_Id
: Entity_Id
:= Empty
;
30861 Keep_Pragma_Id
: Boolean := False) return Node_Id
30863 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
30864 -- Detect whether node N references a formal parameter subject to
30865 -- pragma Unreferenced. If this is the case, set Comes_From_Source
30866 -- to False to suppress the generation of a reference when analyzing
30869 ------------------------
30870 -- Suppress_Reference --
30871 ------------------------
30873 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
30874 Formal
: Entity_Id
;
30877 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30878 Formal
:= Entity
(N
);
30880 -- The formal parameter is subject to pragma Unreferenced. Prevent
30881 -- the generation of references by resetting the Comes_From_Source
30884 if Is_Formal
(Formal
)
30885 and then Has_Pragma_Unreferenced
(Formal
)
30887 Set_Comes_From_Source
(N
, False);
30892 end Suppress_Reference
;
30894 procedure Suppress_References
is
30895 new Traverse_Proc
(Suppress_Reference
);
30899 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
30900 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
30901 Check_Prag
: Node_Id
;
30905 -- Start of processing for Build_Pragma_Check_Equivalent
30908 -- When the pre- or postcondition is inherited, map the formals of the
30909 -- inherited subprogram to those of the current subprogram. In addition,
30910 -- map primitive operations of the parent type into the corresponding
30911 -- primitive operations of the descendant.
30913 if Present
(Inher_Id
) then
30914 pragma Assert
(Present
(Subp_Id
));
30916 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
30918 -- Use generic machinery to copy inherited pragma, as if it were an
30919 -- instantiation, resetting source locations appropriately, so that
30920 -- expressions inside the inherited pragma use chained locations.
30921 -- This is used in particular in GNATprove to locate precisely
30922 -- messages on a given inherited pragma.
30924 Set_Copied_Sloc_For_Inherited_Pragma
30925 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
30926 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
30928 -- Build the inherited class-wide condition
30930 Build_Class_Wide_Expression
30931 (Pragma_Or_Expr
=> Check_Prag
,
30933 Par_Subp
=> Inher_Id
,
30934 Adjust_Sloc
=> True);
30936 -- If not an inherited condition simply copy the original pragma
30939 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
30942 -- Mark the pragma as being internally generated and reset the Analyzed
30945 Set_Analyzed
(Check_Prag
, False);
30946 Set_Comes_From_Source
(Check_Prag
, False);
30948 -- The tree of the original pragma may contain references to the
30949 -- formal parameters of the related subprogram. At the same time
30950 -- the corresponding body may mark the formals as unreferenced:
30952 -- procedure Proc (Formal : ...)
30953 -- with Pre => Formal ...;
30955 -- procedure Proc (Formal : ...) is
30956 -- pragma Unreferenced (Formal);
30959 -- This creates problems because all pragma Check equivalents are
30960 -- analyzed at the end of the body declarations. Since all source
30961 -- references have already been accounted for, reset any references
30962 -- to such formals in the generated pragma Check equivalent.
30964 Suppress_References
(Check_Prag
);
30966 if Present
(Corresponding_Aspect
(Prag
)) then
30967 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
30972 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
30973 -- the copied pragma in the newly created pragma, convert the copy into
30974 -- pragma Check by correcting the name and adding a check_kind argument.
30976 if not Keep_Pragma_Id
then
30977 Set_Class_Present
(Check_Prag
, False);
30979 Set_Pragma_Identifier
30980 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
30982 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
30983 Make_Pragma_Argument_Association
(Loc
,
30984 Expression
=> Make_Identifier
(Loc
, Nam
)));
30987 -- Update the error message when the pragma is inherited
30989 if Present
(Inher_Id
) then
30990 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
30992 if Chars
(Msg_Arg
) = Name_Message
then
30993 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
30995 -- Insert "inherited" to improve the error message
30997 if Name_Buffer
(1 .. 8) = "failed p" then
30998 Insert_Str_In_Name_Buffer
("inherited ", 8);
30999 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
31005 end Build_Pragma_Check_Equivalent
;
31007 -----------------------------
31008 -- Check_Applicable_Policy --
31009 -----------------------------
31011 procedure Check_Applicable_Policy
(N
: Node_Id
) is
31015 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
31018 -- No effect if not valid assertion kind name
31020 if not Is_Valid_Assertion_Kind
(Ename
) then
31024 -- Loop through entries in check policy list
31026 PP
:= Opt
.Check_Policy_List
;
31027 while Present
(PP
) loop
31029 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
31030 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
31034 or else Pnm
= Name_Assertion
31035 or else (Pnm
= Name_Statement_Assertions
31036 and then Ename
in Name_Assert
31037 | Name_Assert_And_Cut
31039 | Name_Loop_Invariant
31040 | Name_Loop_Variant
)
31042 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
31048 -- In CodePeer mode and GNATprove mode, we need to
31049 -- consider all assertions, unless they are disabled.
31050 -- Force Is_Checked on ignored assertions, in particular
31051 -- because transformations of the AST may depend on
31052 -- assertions being checked (e.g. the translation of
31053 -- attribute 'Loop_Entry).
31055 if CodePeer_Mode
or GNATprove_Mode
then
31056 Set_Is_Checked
(N
, True);
31057 Set_Is_Ignored
(N
, False);
31059 Set_Is_Checked
(N
, False);
31060 Set_Is_Ignored
(N
, True);
31066 Set_Is_Checked
(N
, True);
31067 Set_Is_Ignored
(N
, False);
31069 when Name_Disable
=>
31070 Set_Is_Ignored
(N
, True);
31071 Set_Is_Checked
(N
, False);
31072 Set_Is_Disabled
(N
, True);
31074 -- That should be exhaustive, the null here is a defence
31075 -- against a malformed tree from previous errors.
31084 PP
:= Next_Pragma
(PP
);
31088 -- If there are no specific entries that matched, then we let the
31089 -- setting of assertions govern. Note that this provides the needed
31090 -- compatibility with the RM for the cases of assertion, invariant,
31091 -- precondition, predicate, and postcondition. Note also that
31092 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
31094 if Assertions_Enabled
then
31095 Set_Is_Checked
(N
, True);
31096 Set_Is_Ignored
(N
, False);
31098 Set_Is_Checked
(N
, False);
31099 Set_Is_Ignored
(N
, True);
31101 end Check_Applicable_Policy
;
31103 -------------------------------
31104 -- Check_External_Properties --
31105 -------------------------------
31107 procedure Check_External_Properties
31114 type Properties
is array (Positive range 1 .. 4) of Boolean;
31115 type Combinations
is array (Positive range <>) of Properties
;
31116 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
31117 -- Effective_Reads properties and their combinations, respectively.
31119 Specified
: constant Properties
:= (AR
, AW
, EW
, ER
);
31120 -- External properties, as given by the Item pragma
31122 Allowed
: constant Combinations
:=
31123 (1 => (True, False, True, False),
31124 2 => (False, True, False, True),
31125 3 => (True, False, False, False),
31126 4 => (False, True, False, False),
31127 5 => (True, True, True, False),
31128 6 => (True, True, False, True),
31129 7 => (True, True, False, False),
31130 8 => (True, True, True, True));
31131 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
31134 -- Check if the specified properties match any of the allowed
31135 -- combination; if not, then emit an error.
31137 for J
in Allowed
'Range loop
31138 if Specified
= Allowed
(J
) then
31144 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
31146 end Check_External_Properties
;
31152 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
31156 -- Loop through entries in check policy list
31158 PP
:= Opt
.Check_Policy_List
;
31159 while Present
(PP
) loop
31161 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
31162 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
31166 or else (Pnm
= Name_Assertion
31167 and then Is_Valid_Assertion_Kind
(Nam
))
31168 or else (Pnm
= Name_Statement_Assertions
31169 and then Nam
in Name_Assert
31170 | Name_Assert_And_Cut
31172 | Name_Loop_Invariant
31173 | Name_Loop_Variant
)
31175 case Chars
(Get_Pragma_Arg
(Last
(PPA
))) is
31184 return Name_Ignore
;
31186 when Name_Disable
=>
31187 return Name_Disable
;
31190 raise Program_Error
;
31194 PP
:= Next_Pragma
(PP
);
31199 -- If there are no specific entries that matched, then we let the
31200 -- setting of assertions govern. Note that this provides the needed
31201 -- compatibility with the RM for the cases of assertion, invariant,
31202 -- precondition, predicate, and postcondition.
31204 if Assertions_Enabled
then
31207 return Name_Ignore
;
31211 ---------------------------
31212 -- Check_Missing_Part_Of --
31213 ---------------------------
31215 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
31216 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
31217 -- Determine whether a package denoted by Pack_Id declares at least one
31220 -----------------------
31221 -- Has_Visible_State --
31222 -----------------------
31224 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
31225 Item_Id
: Entity_Id
;
31228 -- Traverse the entity chain of the package trying to find at least
31229 -- one visible abstract state, variable or a package [instantiation]
31230 -- that declares a visible state.
31232 Item_Id
:= First_Entity
(Pack_Id
);
31233 while Present
(Item_Id
)
31234 and then not In_Private_Part
(Item_Id
)
31236 -- Do not consider internally generated items
31238 if not Comes_From_Source
(Item_Id
) then
31241 -- Do not consider generic formals or their corresponding actuals
31242 -- because they are not part of a visible state. Note that both
31243 -- entities are marked as hidden.
31245 elsif Is_Hidden
(Item_Id
) then
31248 -- A visible state has been found. Note that constants are not
31249 -- considered here because it is not possible to determine whether
31250 -- they depend on variable input. This check is left to the SPARK
31253 elsif Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
31256 -- Recursively peek into nested packages and instantiations
31258 elsif Ekind
(Item_Id
) = E_Package
31259 and then Has_Visible_State
(Item_Id
)
31264 Next_Entity
(Item_Id
);
31268 end Has_Visible_State
;
31272 Pack_Id
: Entity_Id
;
31273 Placement
: State_Space_Kind
;
31275 -- Start of processing for Check_Missing_Part_Of
31278 -- Do not consider abstract states, variables or package instantiations
31279 -- coming from an instance as those always inherit the Part_Of indicator
31280 -- of the instance itself.
31282 if In_Instance
then
31285 -- Do not consider internally generated entities as these can never
31286 -- have a Part_Of indicator.
31288 elsif not Comes_From_Source
(Item_Id
) then
31291 -- Perform these checks only when SPARK_Mode is enabled as they will
31292 -- interfere with standard Ada rules and produce false positives.
31294 elsif SPARK_Mode
/= On
then
31297 -- Do not consider constants, because the compiler cannot accurately
31298 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
31299 -- act as a hidden state of a package.
31301 elsif Ekind
(Item_Id
) = E_Constant
then
31305 -- Find where the abstract state, variable or package instantiation
31306 -- lives with respect to the state space.
31308 Find_Placement_In_State_Space
31309 (Item_Id
=> Item_Id
,
31310 Placement
=> Placement
,
31311 Pack_Id
=> Pack_Id
);
31313 -- Items that appear in a non-package construct (subprogram, block, etc)
31314 -- do not require a Part_Of indicator because they can never act as a
31317 if Placement
= Not_In_Package
then
31320 -- An item declared in the body state space of a package always act as a
31321 -- constituent and does not need explicit Part_Of indicator.
31323 elsif Placement
= Body_State_Space
then
31326 -- In general an item declared in the visible state space of a package
31327 -- does not require a Part_Of indicator. The only exception is when the
31328 -- related package is a nongeneric private child unit, in which case
31329 -- Part_Of must denote a state in the parent unit or in one of its
31332 elsif Placement
= Visible_State_Space
then
31333 if Is_Child_Unit
(Pack_Id
)
31334 and then not Is_Generic_Unit
(Pack_Id
)
31335 and then Is_Private_Descendant
(Pack_Id
)
31337 -- A package instantiation does not need a Part_Of indicator when
31338 -- the related generic template has no visible state.
31340 if Ekind
(Item_Id
) = E_Package
31341 and then Is_Generic_Instance
(Item_Id
)
31342 and then not Has_Visible_State
(Item_Id
)
31346 -- All other cases require Part_Of
31350 ("indicator Part_Of is required in this context "
31351 & "(SPARK RM 7.2.6(3))", Item_Id
);
31352 Error_Msg_Name_1
:= Chars
(Pack_Id
);
31354 ("\& is declared in the visible part of private child "
31355 & "unit %", Item_Id
);
31359 -- When the item appears in the private state space of a package, it
31360 -- must be a part of some state declared by the said package.
31362 else pragma Assert
(Placement
= Private_State_Space
);
31364 -- The related package does not declare a state, the item cannot act
31365 -- as a Part_Of constituent.
31367 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
31370 -- A package instantiation does not need a Part_Of indicator when the
31371 -- related generic template has no visible state.
31373 elsif Ekind
(Item_Id
) = E_Package
31374 and then Is_Generic_Instance
(Item_Id
)
31375 and then not Has_Visible_State
(Item_Id
)
31379 -- All other cases require Part_Of
31382 Error_Msg_Code
:= GEC_Required_Part_Of
;
31384 ("indicator Part_Of is required in this context '[[]']",
31386 Error_Msg_Name_1
:= Chars
(Pack_Id
);
31388 ("\& is declared in the private part of package %", Item_Id
);
31391 end Check_Missing_Part_Of
;
31393 ---------------------------------------------------
31394 -- Check_Postcondition_Use_In_Inlined_Subprogram --
31395 ---------------------------------------------------
31397 procedure Check_Postcondition_Use_In_Inlined_Subprogram
31399 Spec_Id
: Entity_Id
)
31402 if Warn_On_Redundant_Constructs
31403 and then Has_Pragma_Inline_Always
(Spec_Id
)
31404 and then Assertions_Enabled
31405 and then not Back_End_Inlining
31407 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
31409 if From_Aspect_Specification
(Prag
) then
31411 ("aspect % not enforced on inlined subprogram &?r?",
31412 Corresponding_Aspect
(Prag
), Spec_Id
);
31415 ("pragma % not enforced on inlined subprogram &?r?",
31419 end Check_Postcondition_Use_In_Inlined_Subprogram
;
31421 -------------------------------------
31422 -- Check_State_And_Constituent_Use --
31423 -------------------------------------
31425 procedure Check_State_And_Constituent_Use
31426 (States
: Elist_Id
;
31427 Constits
: Elist_Id
;
31430 Constit_Elmt
: Elmt_Id
;
31431 Constit_Id
: Entity_Id
;
31432 State_Id
: Entity_Id
;
31435 -- Nothing to do if there are no states or constituents
31437 if No
(States
) or else No
(Constits
) then
31441 -- Inspect the list of constituents and try to determine whether its
31442 -- encapsulating state is in list States.
31444 Constit_Elmt
:= First_Elmt
(Constits
);
31445 while Present
(Constit_Elmt
) loop
31446 Constit_Id
:= Node
(Constit_Elmt
);
31448 -- Determine whether the constituent is part of an encapsulating
31449 -- state that appears in the same context and if this is the case,
31450 -- emit an error (SPARK RM 7.2.6(7)).
31452 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
31454 if Present
(State_Id
) then
31455 Error_Msg_Name_1
:= Chars
(Constit_Id
);
31457 ("cannot mention state & and its constituent % in the same "
31458 & "context", Context
, State_Id
);
31462 Next_Elmt
(Constit_Elmt
);
31464 end Check_State_And_Constituent_Use
;
31466 ---------------------------------------------
31467 -- Collect_Inherited_Class_Wide_Conditions --
31468 ---------------------------------------------
31470 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
31471 Parent_Subp
: constant Entity_Id
:=
31472 Ultimate_Alias
(Overridden_Operation
(Subp
));
31473 -- The Overridden_Operation may itself be inherited and as such have no
31474 -- explicit contract.
31476 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
31477 In_Spec_Expr
: Boolean := In_Spec_Expression
;
31478 Installed
: Boolean;
31480 New_Prag
: Node_Id
;
31483 Installed
:= False;
31485 -- Iterate over the contract of the overridden subprogram to find all
31486 -- inherited class-wide pre- and postconditions.
31488 if Present
(Prags
) then
31489 Prag
:= Pre_Post_Conditions
(Prags
);
31491 while Present
(Prag
) loop
31492 if Pragma_Name_Unmapped
(Prag
)
31493 in Name_Precondition | Name_Postcondition
31494 and then Class_Present
(Prag
)
31496 -- The generated pragma must be analyzed in the context of
31497 -- the subprogram, to make its formals visible. In addition,
31498 -- we must inhibit freezing and full analysis because the
31499 -- controlling type of the subprogram is not frozen yet, and
31500 -- may have further primitives.
31502 if not Installed
then
31505 Install_Formals
(Subp
);
31506 In_Spec_Expr
:= In_Spec_Expression
;
31507 In_Spec_Expression
:= True;
31511 Build_Pragma_Check_Equivalent
31512 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
31514 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
31515 Preanalyze
(New_Prag
);
31517 -- Prevent further analysis in subsequent processing of the
31518 -- current list of declarations
31520 Set_Analyzed
(New_Prag
);
31523 Prag
:= Next_Pragma
(Prag
);
31527 In_Spec_Expression
:= In_Spec_Expr
;
31531 end Collect_Inherited_Class_Wide_Conditions
;
31533 ---------------------------------------
31534 -- Collect_Subprogram_Inputs_Outputs --
31535 ---------------------------------------
31537 procedure Collect_Subprogram_Inputs_Outputs
31538 (Subp_Id
: Entity_Id
;
31539 Synthesize
: Boolean := False;
31540 Subp_Inputs
: in out Elist_Id
;
31541 Subp_Outputs
: in out Elist_Id
;
31542 Global_Seen
: out Boolean)
31544 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
31545 -- Collect all relevant items from a dependency clause
31547 procedure Collect_Global_List
31549 Mode
: Name_Id
:= Name_Input
);
31550 -- Collect all relevant items from a global list
31552 -------------------------------
31553 -- Collect_Dependency_Clause --
31554 -------------------------------
31556 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
31557 procedure Collect_Dependency_Item
31559 Is_Input
: Boolean);
31560 -- Add an item to the proper subprogram input or output collection
31562 -----------------------------
31563 -- Collect_Dependency_Item --
31564 -----------------------------
31566 procedure Collect_Dependency_Item
31568 Is_Input
: Boolean)
31573 -- Nothing to collect when the item is null
31575 if Nkind
(Item
) = N_Null
then
31578 -- Ditto for attribute 'Result
31580 elsif Is_Attribute_Result
(Item
) then
31583 -- Multiple items appear as an aggregate
31585 elsif Nkind
(Item
) = N_Aggregate
then
31586 Extra
:= First
(Expressions
(Item
));
31587 while Present
(Extra
) loop
31588 Collect_Dependency_Item
(Extra
, Is_Input
);
31592 -- Otherwise this is a solitary item
31596 Append_New_Elmt
(Item
, Subp_Inputs
);
31598 Append_New_Elmt
(Item
, Subp_Outputs
);
31601 end Collect_Dependency_Item
;
31603 -- Start of processing for Collect_Dependency_Clause
31606 if Nkind
(Clause
) = N_Null
then
31609 -- A dependency clause appears as component association
31611 elsif Nkind
(Clause
) = N_Component_Association
then
31612 Collect_Dependency_Item
31613 (Item
=> Expression
(Clause
),
31616 Collect_Dependency_Item
31617 (Item
=> First
(Choices
(Clause
)),
31618 Is_Input
=> False);
31620 -- To accommodate partial decoration of disabled SPARK features, this
31621 -- routine may be called with illegal input. If this is the case, do
31622 -- not raise Program_Error.
31627 end Collect_Dependency_Clause
;
31629 -------------------------
31630 -- Collect_Global_List --
31631 -------------------------
31633 procedure Collect_Global_List
31635 Mode
: Name_Id
:= Name_Input
)
31637 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
31638 -- Add an item to the proper subprogram input or output collection
31640 -------------------------
31641 -- Collect_Global_Item --
31642 -------------------------
31644 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
31646 if Mode
in Name_In_Out | Name_Input
then
31647 Append_New_Elmt
(Item
, Subp_Inputs
);
31650 if Mode
in Name_In_Out | Name_Output
then
31651 Append_New_Elmt
(Item
, Subp_Outputs
);
31653 end Collect_Global_Item
;
31660 -- Start of processing for Collect_Global_List
31663 if Nkind
(List
) = N_Null
then
31666 -- Single global item declaration
31668 elsif Nkind
(List
) in N_Expanded_Name
31670 | N_Selected_Component
31672 Collect_Global_Item
(List
, Mode
);
31674 -- Simple global list or moded global list declaration
31676 elsif Nkind
(List
) = N_Aggregate
then
31677 if Present
(Expressions
(List
)) then
31678 Item
:= First
(Expressions
(List
));
31679 while Present
(Item
) loop
31680 Collect_Global_Item
(Item
, Mode
);
31685 Assoc
:= First
(Component_Associations
(List
));
31686 while Present
(Assoc
) loop
31687 Collect_Global_List
31688 (List
=> Expression
(Assoc
),
31689 Mode
=> Chars
(First
(Choices
(Assoc
))));
31694 -- To accommodate partial decoration of disabled SPARK features, this
31695 -- routine may be called with illegal input. If this is the case, do
31696 -- not raise Program_Error.
31701 end Collect_Global_List
;
31708 Formal
: Entity_Id
;
31710 Spec_Id
: Entity_Id
:= Empty
;
31711 Subp_Decl
: Node_Id
;
31714 -- Start of processing for Collect_Subprogram_Inputs_Outputs
31717 Global_Seen
:= False;
31719 -- Process all formal parameters of entries, [generic] subprograms, and
31722 if Ekind
(Subp_Id
) in E_Entry
31725 | E_Generic_Function
31726 | E_Generic_Procedure
31728 | E_Subprogram_Body
31730 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
31731 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
31733 -- Process all formal parameters
31735 Formal
:= First_Formal
(Spec_Id
);
31736 while Present
(Formal
) loop
31737 if Ekind
(Formal
) in E_In_Out_Parameter | E_In_Parameter
then
31738 Append_New_Elmt
(Formal
, Subp_Inputs
);
31741 if Ekind
(Formal
) in E_In_Out_Parameter | E_Out_Parameter
then
31742 Append_New_Elmt
(Formal
, Subp_Outputs
);
31744 -- OUT parameters can act as inputs when the related type is
31745 -- tagged, unconstrained array, unconstrained record, or record
31746 -- with unconstrained components.
31748 if Ekind
(Formal
) = E_Out_Parameter
31749 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
31751 Append_New_Elmt
(Formal
, Subp_Inputs
);
31755 -- IN parameters of procedures and protected entries can act as
31756 -- outputs when the related type is access-to-variable.
31758 if Ekind
(Formal
) = E_In_Parameter
31759 and then Ekind
(Spec_Id
) not in E_Function
31760 | E_Generic_Function
31761 and then Is_Access_Variable
(Etype
(Formal
))
31763 Append_New_Elmt
(Formal
, Subp_Outputs
);
31766 Next_Formal
(Formal
);
31769 -- Otherwise the input denotes a task type, a task body, or the
31770 -- anonymous object created for a single task type.
31772 elsif Ekind
(Subp_Id
) in E_Task_Type | E_Task_Body
31773 or else Is_Single_Task_Object
(Subp_Id
)
31775 Subp_Decl
:= Declaration_Node
(Subp_Id
);
31776 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
31779 -- When processing an entry, subprogram or task body, look for pragmas
31780 -- Refined_Depends and Refined_Global as they specify the inputs and
31783 if Is_Entry_Body
(Subp_Id
)
31784 or else Ekind
(Subp_Id
) in E_Subprogram_Body | E_Task_Body
31786 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
31787 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
31789 -- Subprogram declaration or stand-alone body case, look for pragmas
31790 -- Depends and Global.
31793 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
31794 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
31797 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
31798 -- because it provides finer granularity of inputs and outputs.
31800 if Present
(Global
) then
31801 Global_Seen
:= True;
31802 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
31804 -- When the related subprogram lacks pragma [Refined_]Global, fall back
31805 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
31806 -- the inputs and outputs from [Refined_]Depends.
31808 elsif Synthesize
and then Present
(Depends
) then
31809 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
31811 -- Multiple dependency clauses appear as an aggregate
31813 if Nkind
(Clauses
) = N_Aggregate
then
31814 Clause
:= First
(Component_Associations
(Clauses
));
31815 while Present
(Clause
) loop
31816 Collect_Dependency_Clause
(Clause
);
31820 -- Otherwise this is a single dependency clause
31823 Collect_Dependency_Clause
(Clauses
);
31827 -- The current instance of a protected type acts as a formal parameter
31828 -- of mode IN for functions and IN OUT for entries and procedures
31829 -- (SPARK RM 6.1.4).
31831 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
31832 Typ
:= Scope
(Spec_Id
);
31834 -- Use the anonymous object when the type is single protected
31836 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
31837 Typ
:= Anonymous_Object
(Typ
);
31840 Append_New_Elmt
(Typ
, Subp_Inputs
);
31842 if Ekind
(Spec_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
31843 Append_New_Elmt
(Typ
, Subp_Outputs
);
31846 -- The current instance of a task type acts as a formal parameter of
31847 -- mode IN OUT (SPARK RM 6.1.4).
31849 elsif Ekind
(Spec_Id
) = E_Task_Type
then
31852 -- Use the anonymous object when the type is single task
31854 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
31855 Typ
:= Anonymous_Object
(Typ
);
31858 Append_New_Elmt
(Typ
, Subp_Inputs
);
31859 Append_New_Elmt
(Typ
, Subp_Outputs
);
31861 elsif Is_Single_Task_Object
(Spec_Id
) then
31862 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
31863 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
31865 end Collect_Subprogram_Inputs_Outputs
;
31867 ---------------------------
31868 -- Contract_Freeze_Error --
31869 ---------------------------
31871 procedure Contract_Freeze_Error
31872 (Contract_Id
: Entity_Id
;
31873 Freeze_Id
: Entity_Id
)
31876 Error_Msg_Name_1
:= Chars
(Contract_Id
);
31877 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
31880 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
31882 ("\all contractual items must be declared before body #", Contract_Id
);
31883 end Contract_Freeze_Error
;
31885 ---------------------------------
31886 -- Delay_Config_Pragma_Analyze --
31887 ---------------------------------
31889 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
31891 return Pragma_Name_Unmapped
(N
)
31892 in Name_Interrupt_State | Name_Priority_Specific_Dispatching
;
31893 end Delay_Config_Pragma_Analyze
;
31895 -----------------------
31896 -- Duplication_Error --
31897 -----------------------
31899 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
31900 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
31901 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
31904 Error_Msg_Sloc
:= Sloc
(Prev
);
31905 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
31907 -- Emit a precise message to distinguish between source pragmas and
31908 -- pragmas generated from aspects. The ordering of the two pragmas is
31912 -- Prag -- duplicate
31914 -- No error is emitted when both pragmas come from aspects because this
31915 -- is already detected by the general aspect analysis mechanism.
31917 if Prag_From_Asp
and Prev_From_Asp
then
31919 elsif Prag_From_Asp
then
31920 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
31921 elsif Prev_From_Asp
then
31922 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
31924 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
31926 end Duplication_Error
;
31928 ------------------------------
31929 -- Find_Encapsulating_State --
31930 ------------------------------
31932 function Find_Encapsulating_State
31933 (States
: Elist_Id
;
31934 Constit_Id
: Entity_Id
) return Entity_Id
31936 State_Id
: Entity_Id
;
31939 -- Since a constituent may be part of a larger constituent set, climb
31940 -- the encapsulating state chain looking for a state that appears in
31943 State_Id
:= Encapsulating_State
(Constit_Id
);
31944 while Present
(State_Id
) loop
31945 if Contains
(States
, State_Id
) then
31949 State_Id
:= Encapsulating_State
(State_Id
);
31953 end Find_Encapsulating_State
;
31955 --------------------------
31956 -- Find_Related_Context --
31957 --------------------------
31959 function Find_Related_Context
31961 Do_Checks
: Boolean := False) return Node_Id
31966 -- If the pragma comes from an aspect on a compilation unit that is a
31967 -- package instance, then return the original package instantiation
31970 if Nkind
(Parent
(Prag
)) = N_Compilation_Unit_Aux
then
31972 Get_Unit_Instantiation_Node
31973 (Defining_Entity
(Unit
(Enclosing_Comp_Unit_Node
(Prag
))));
31976 Stmt
:= Prev
(Prag
);
31977 while Present
(Stmt
) loop
31979 -- Skip prior pragmas, but check for duplicates
31981 if Nkind
(Stmt
) = N_Pragma
then
31983 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
31990 -- Skip internally generated code
31992 elsif not Comes_From_Source
(Stmt
)
31993 and then not Comes_From_Source
(Original_Node
(Stmt
))
31996 -- The anonymous object created for a single concurrent type is a
31997 -- suitable context.
31999 if Nkind
(Stmt
) = N_Object_Declaration
32000 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
32005 -- Return the current source construct
32015 end Find_Related_Context
;
32017 --------------------------------------
32018 -- Find_Related_Declaration_Or_Body --
32019 --------------------------------------
32021 function Find_Related_Declaration_Or_Body
32023 Do_Checks
: Boolean := False) return Node_Id
32025 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
32027 procedure Expression_Function_Error
;
32028 -- Emit an error concerning pragma Prag that illegaly applies to an
32029 -- expression function.
32031 -------------------------------
32032 -- Expression_Function_Error --
32033 -------------------------------
32035 procedure Expression_Function_Error
is
32037 Error_Msg_Name_1
:= Prag_Nam
;
32039 -- Emit a precise message to distinguish between source pragmas and
32040 -- pragmas generated from aspects.
32042 if From_Aspect_Specification
(Prag
) then
32044 ("aspect % cannot apply to a standalone expression function",
32048 ("pragma % cannot apply to a standalone expression function",
32051 end Expression_Function_Error
;
32055 Context
: constant Node_Id
:= Parent
(Prag
);
32058 Look_For_Body
: constant Boolean :=
32059 Prag_Nam
in Name_Refined_Depends
32060 | Name_Refined_Global
32061 | Name_Refined_Post
32062 | Name_Refined_State
;
32063 -- Refinement pragmas must be associated with a subprogram body [stub]
32065 -- Start of processing for Find_Related_Declaration_Or_Body
32068 Stmt
:= Prev
(Prag
);
32069 while Present
(Stmt
) loop
32071 -- Skip prior pragmas, but check for duplicates. Pragmas produced
32072 -- by splitting a complex pre/postcondition are not considered to
32075 if Nkind
(Stmt
) = N_Pragma
then
32077 and then not Split_PPC
(Stmt
)
32078 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
32085 -- Emit an error when a refinement pragma appears on an expression
32086 -- function without a completion.
32089 and then Look_For_Body
32090 and then Nkind
(Stmt
) = N_Subprogram_Declaration
32091 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
32092 and then not Has_Completion
(Defining_Entity
(Stmt
))
32094 Expression_Function_Error
;
32097 -- The refinement pragma applies to a subprogram body stub
32099 elsif Look_For_Body
32100 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
32104 -- Skip internally generated code
32106 elsif not Comes_From_Source
(Stmt
) then
32108 -- The anonymous object created for a single concurrent type is a
32109 -- suitable context.
32111 if Nkind
(Stmt
) = N_Object_Declaration
32112 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
32116 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
32118 -- The subprogram declaration is an internally generated spec
32119 -- for an expression function.
32121 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
32124 -- The subprogram declaration is an internally generated spec
32125 -- for a stand-alone subprogram body declared inside a
32128 elsif Present
(Corresponding_Body
(Stmt
))
32129 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
32130 and then Is_Protected_Type
(Current_Scope
)
32134 -- The subprogram is actually an instance housed within an
32135 -- anonymous wrapper package.
32137 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
32140 -- Ada 2022: contract on formal subprogram or on generated
32141 -- Access_Subprogram_Wrapper, which appears after the related
32142 -- Access_Subprogram declaration.
32144 elsif Is_Generic_Actual_Subprogram
(Defining_Entity
(Stmt
))
32145 and then Ada_Version
>= Ada_2022
32149 elsif Is_Access_Subprogram_Wrapper
(Defining_Entity
(Stmt
))
32150 and then Ada_Version
>= Ada_2022
32156 -- Return the current construct which is either a subprogram body,
32157 -- a subprogram declaration or is illegal.
32166 -- If we fall through, then the pragma was either the first declaration
32167 -- or it was preceded by other pragmas and no source constructs.
32169 -- The pragma is associated with a library-level subprogram
32171 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
32172 return Unit
(Parent
(Context
));
32174 -- The pragma appears inside the declarations of an entry body
32176 elsif Nkind
(Context
) = N_Entry_Body
then
32179 -- The pragma appears inside the statements of a subprogram body at
32180 -- some nested level.
32182 elsif Is_Statement
(Context
)
32183 and then Present
(Enclosing_HSS
(Context
))
32185 return Parent
(Enclosing_HSS
(Context
));
32187 -- The pragma appears directly in the statements of a subprogram body
32189 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
32190 return Parent
(Context
);
32192 -- The pragma appears inside the declarative part of a package body
32194 elsif Nkind
(Context
) = N_Package_Body
then
32197 -- The pragma appears inside the declarative part of a subprogram body
32199 elsif Nkind
(Context
) = N_Subprogram_Body
then
32202 -- The pragma appears inside the declarative part of a task body
32204 elsif Nkind
(Context
) = N_Task_Body
then
32207 -- The pragma appears inside the visible part of a package specification
32209 elsif Nkind
(Context
) = N_Package_Specification
then
32210 return Parent
(Context
);
32212 -- The pragma is a byproduct of aspect expansion, return the related
32213 -- context of the original aspect. This case has a lower priority as
32214 -- the above circuitry pinpoints precisely the related context.
32216 elsif Present
(Corresponding_Aspect
(Prag
)) then
32217 return Parent
(Corresponding_Aspect
(Prag
));
32219 -- No candidate subprogram [body] found
32224 end Find_Related_Declaration_Or_Body
;
32226 ----------------------------------
32227 -- Find_Related_Package_Or_Body --
32228 ----------------------------------
32230 function Find_Related_Package_Or_Body
32232 Do_Checks
: Boolean := False) return Node_Id
32234 Context
: constant Node_Id
:= Parent
(Prag
);
32235 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
32239 Stmt
:= Prev
(Prag
);
32240 while Present
(Stmt
) loop
32242 -- Skip prior pragmas, but check for duplicates
32244 if Nkind
(Stmt
) = N_Pragma
then
32245 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
32251 -- Skip internally generated code
32253 elsif not Comes_From_Source
(Stmt
) then
32254 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
32256 -- The subprogram declaration is an internally generated spec
32257 -- for an expression function.
32259 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
32262 -- The subprogram is actually an instance housed within an
32263 -- anonymous wrapper package.
32265 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
32270 -- Return the current source construct which is illegal
32279 -- If we fall through, then the pragma was either the first declaration
32280 -- or it was preceded by other pragmas and no source constructs.
32282 -- The pragma is associated with a package. The immediate context in
32283 -- this case is the specification of the package.
32285 if Nkind
(Context
) = N_Package_Specification
then
32286 return Parent
(Context
);
32288 -- The pragma appears in the declarations of a package body
32290 elsif Nkind
(Context
) = N_Package_Body
then
32293 -- The pragma appears in the statements of a package body
32295 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
32296 and then Nkind
(Parent
(Context
)) = N_Package_Body
32298 return Parent
(Context
);
32300 -- The pragma is a byproduct of aspect expansion, return the related
32301 -- context of the original aspect. This case has a lower priority as
32302 -- the above circuitry pinpoints precisely the related context.
32304 elsif Present
(Corresponding_Aspect
(Prag
)) then
32305 return Parent
(Corresponding_Aspect
(Prag
));
32307 -- No candidate package [body] found
32312 end Find_Related_Package_Or_Body
;
32318 function Get_Argument
32320 Context_Id
: Entity_Id
:= Empty
) return Node_Id
32322 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
32325 -- Use the expression of the original aspect when analyzing the template
32326 -- of a generic unit. In both cases the aspect's tree must be decorated
32327 -- to save the global references in the generic context.
32329 if From_Aspect_Specification
(Prag
)
32330 and then Present
(Context_Id
)
32332 Is_Generic_Declaration_Or_Body
(Unit_Declaration_Node
(Context_Id
))
32334 return Corresponding_Aspect
(Prag
);
32336 -- Otherwise use the expression of the pragma
32338 elsif Present
(Args
) then
32339 return First
(Args
);
32346 -------------------------
32347 -- Get_Base_Subprogram --
32348 -------------------------
32350 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
32352 -- Follow subprogram renaming chain
32354 if Is_Subprogram
(Def_Id
)
32355 and then Parent_Kind
(Declaration_Node
(Def_Id
)) =
32356 N_Subprogram_Renaming_Declaration
32357 and then Present
(Alias
(Def_Id
))
32359 return Alias
(Def_Id
);
32363 end Get_Base_Subprogram
;
32365 -------------------------
32366 -- Get_SPARK_Mode_Type --
32367 -------------------------
32369 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
32379 -- Any other argument is illegal. Assume that no SPARK mode applies
32380 -- to avoid potential cascaded errors.
32385 end Get_SPARK_Mode_Type
;
32387 ------------------------------------
32388 -- Get_SPARK_Mode_From_Annotation --
32389 ------------------------------------
32391 function Get_SPARK_Mode_From_Annotation
32392 (N
: Node_Id
) return SPARK_Mode_Type
32397 if Nkind
(N
) = N_Aspect_Specification
then
32398 Mode
:= Expression
(N
);
32400 else pragma Assert
(Nkind
(N
) = N_Pragma
);
32401 Mode
:= First
(Pragma_Argument_Associations
(N
));
32403 if Present
(Mode
) then
32404 Mode
:= Get_Pragma_Arg
(Mode
);
32408 -- Aspect or pragma SPARK_Mode specifies an explicit mode
32410 if Present
(Mode
) then
32411 if Nkind
(Mode
) = N_Identifier
then
32412 return Get_SPARK_Mode_Type
(Chars
(Mode
));
32414 -- In case of a malformed aspect or pragma, return the default None
32420 -- Otherwise the lack of an expression defaults SPARK_Mode to On
32425 end Get_SPARK_Mode_From_Annotation
;
32427 ---------------------------
32428 -- Has_Extra_Parentheses --
32429 ---------------------------
32431 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
32435 -- The aggregate should not have an expression list because a clause
32436 -- is always interpreted as a component association. The only way an
32437 -- expression list can sneak in is by adding extra parentheses around
32438 -- the individual clauses:
32440 -- Depends (Output => Input) -- proper form
32441 -- Depends ((Output => Input)) -- extra parentheses
32443 -- Since the extra parentheses are not allowed by the syntax of the
32444 -- pragma, flag them now to avoid emitting misleading errors down the
32447 if Nkind
(Clause
) = N_Aggregate
32448 and then Present
(Expressions
(Clause
))
32450 Expr
:= First
(Expressions
(Clause
));
32451 while Present
(Expr
) loop
32453 -- A dependency clause surrounded by extra parentheses appears
32454 -- as an aggregate of component associations with an optional
32455 -- Paren_Count set.
32457 if Nkind
(Expr
) = N_Aggregate
32458 and then Present
(Component_Associations
(Expr
))
32461 ("dependency clause contains extra parentheses", Expr
);
32463 -- Otherwise the expression is a malformed construct
32466 SPARK_Msg_N
("malformed dependency clause", Expr
);
32476 end Has_Extra_Parentheses
;
32482 procedure Initialize
is
32485 Compile_Time_Warnings_Errors
.Init
;
32494 Dummy
:= Dummy
+ 1;
32497 -----------------------------
32498 -- Is_Config_Static_String --
32499 -----------------------------
32501 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
32503 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
32504 -- This is an internal recursive function that is just like the outer
32505 -- function except that it adds the string to the name buffer rather
32506 -- than placing the string in the name buffer.
32508 ------------------------------
32509 -- Add_Config_Static_String --
32510 ------------------------------
32512 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
32519 if Nkind
(N
) = N_Op_Concat
then
32520 if Add_Config_Static_String
(Left_Opnd
(N
)) then
32521 N
:= Right_Opnd
(N
);
32527 if Nkind
(N
) /= N_String_Literal
then
32528 Error_Msg_N
("string literal expected for pragma argument", N
);
32532 for J
in 1 .. String_Length
(Strval
(N
)) loop
32533 C
:= Get_String_Char
(Strval
(N
), J
);
32535 if not In_Character_Range
(C
) then
32537 ("string literal contains invalid wide character",
32538 Sloc
(N
) + 1 + Source_Ptr
(J
));
32542 Add_Char_To_Name_Buffer
(Get_Character
(C
));
32547 end Add_Config_Static_String
;
32549 -- Start of processing for Is_Config_Static_String
32554 return Add_Config_Static_String
(Arg
);
32555 end Is_Config_Static_String
;
32557 -------------------------------
32558 -- Is_Elaboration_SPARK_Mode --
32559 -------------------------------
32561 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
32564 (Nkind
(N
) = N_Pragma
32565 and then Pragma_Name
(N
) = Name_SPARK_Mode
32566 and then Is_List_Member
(N
));
32568 -- Pragma SPARK_Mode affects the elaboration of a package body when it
32569 -- appears in the statement part of the body.
32572 Present
(Parent
(N
))
32573 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
32574 and then List_Containing
(N
) = Statements
(Parent
(N
))
32575 and then Present
(Parent
(Parent
(N
)))
32576 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
32577 end Is_Elaboration_SPARK_Mode
;
32579 -----------------------
32580 -- Is_Enabled_Pragma --
32581 -----------------------
32583 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
32587 if Present
(Prag
) then
32588 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32590 if Present
(Arg
) then
32591 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
32593 -- The lack of a Boolean argument automatically enables the pragma
32599 -- The pragma is missing, therefore it is not enabled
32604 end Is_Enabled_Pragma
;
32606 -----------------------------------------
32607 -- Is_Non_Significant_Pragma_Reference --
32608 -----------------------------------------
32610 -- This function makes use of the following static table which indicates
32611 -- whether appearance of some name in a given pragma is to be considered
32612 -- as a reference for the purposes of warnings about unreferenced objects.
32614 -- -1 indicates that appearance in any argument is significant
32615 -- 0 indicates that appearance in any argument is not significant
32616 -- +n indicates that appearance as argument n is significant, but all
32617 -- other arguments are not significant
32618 -- 9n arguments from n on are significant, before n insignificant
32620 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
32621 (Pragma_Abort_Defer
=> -1,
32622 Pragma_Abstract_State
=> -1,
32623 Pragma_Ada_83
=> -1,
32624 Pragma_Ada_95
=> -1,
32625 Pragma_Ada_05
=> -1,
32626 Pragma_Ada_2005
=> -1,
32627 Pragma_Ada_12
=> -1,
32628 Pragma_Ada_2012
=> -1,
32629 Pragma_Ada_2022
=> -1,
32630 Pragma_Aggregate_Individually_Assign
=> 0,
32631 Pragma_All_Calls_Remote
=> -1,
32632 Pragma_Allow_Integer_Address
=> -1,
32633 Pragma_Always_Terminates
=> -1,
32634 Pragma_Annotate
=> 93,
32635 Pragma_Assert
=> -1,
32636 Pragma_Assert_And_Cut
=> -1,
32637 Pragma_Assertion_Policy
=> 0,
32638 Pragma_Assume
=> -1,
32639 Pragma_Assume_No_Invalid_Values
=> 0,
32640 Pragma_Async_Readers
=> 0,
32641 Pragma_Async_Writers
=> 0,
32642 Pragma_Asynchronous
=> 0,
32643 Pragma_Atomic
=> 0,
32644 Pragma_Atomic_Components
=> 0,
32645 Pragma_Attach_Handler
=> -1,
32646 Pragma_Attribute_Definition
=> 92,
32647 Pragma_Check
=> -1,
32648 Pragma_Check_Float_Overflow
=> 0,
32649 Pragma_Check_Name
=> 0,
32650 Pragma_Check_Policy
=> 0,
32651 Pragma_CPP_Class
=> 0,
32652 Pragma_CPP_Constructor
=> 0,
32653 Pragma_CPP_Virtual
=> 0,
32654 Pragma_CPP_Vtable
=> 0,
32656 Pragma_C_Pass_By_Copy
=> 0,
32657 Pragma_Comment
=> -1,
32658 Pragma_Common_Object
=> 0,
32659 Pragma_CUDA_Device
=> -1,
32660 Pragma_CUDA_Execute
=> -1,
32661 Pragma_CUDA_Global
=> -1,
32662 Pragma_Compile_Time_Error
=> -1,
32663 Pragma_Compile_Time_Warning
=> -1,
32664 Pragma_Complete_Representation
=> 0,
32665 Pragma_Complex_Representation
=> 0,
32666 Pragma_Component_Alignment
=> 0,
32667 Pragma_Constant_After_Elaboration
=> 0,
32668 Pragma_Contract_Cases
=> -1,
32669 Pragma_Controlled
=> 0,
32670 Pragma_Convention
=> 0,
32671 Pragma_Convention_Identifier
=> 0,
32672 Pragma_Deadline_Floor
=> -1,
32673 Pragma_Debug
=> -1,
32674 Pragma_Debug_Policy
=> 0,
32675 Pragma_Default_Initial_Condition
=> -1,
32676 Pragma_Default_Scalar_Storage_Order
=> 0,
32677 Pragma_Default_Storage_Pool
=> 0,
32678 Pragma_Depends
=> -1,
32679 Pragma_Detect_Blocking
=> 0,
32680 Pragma_Disable_Atomic_Synchronization
=> 0,
32681 Pragma_Discard_Names
=> 0,
32682 Pragma_Dispatching_Domain
=> -1,
32683 Pragma_Effective_Reads
=> 0,
32684 Pragma_Effective_Writes
=> 0,
32685 Pragma_Elaborate
=> 0,
32686 Pragma_Elaborate_All
=> 0,
32687 Pragma_Elaborate_Body
=> 0,
32688 Pragma_Elaboration_Checks
=> 0,
32689 Pragma_Eliminate
=> 0,
32690 Pragma_Enable_Atomic_Synchronization
=> 0,
32691 Pragma_Exceptional_Cases
=> -1,
32692 Pragma_Export
=> -1,
32693 Pragma_Export_Function
=> -1,
32694 Pragma_Export_Object
=> -1,
32695 Pragma_Export_Procedure
=> -1,
32696 Pragma_Export_Valued_Procedure
=> -1,
32697 Pragma_Extend_System
=> -1,
32698 Pragma_Extensions_Allowed
=> 0,
32699 Pragma_Extensions_Visible
=> 0,
32700 Pragma_External
=> -1,
32701 Pragma_External_Name_Casing
=> 0,
32702 Pragma_Fast_Math
=> 0,
32703 Pragma_Favor_Top_Level
=> 0,
32704 Pragma_Finalize_Storage_Only
=> 0,
32706 Pragma_Global
=> -1,
32707 Pragma_GNAT_Annotate
=> 93,
32708 Pragma_Ident
=> -1,
32709 Pragma_Ignore_Pragma
=> 0,
32710 Pragma_Implementation_Defined
=> -1,
32711 Pragma_Implemented
=> -1,
32712 Pragma_Implicit_Packing
=> 0,
32713 Pragma_Import
=> 93,
32714 Pragma_Import_Function
=> 0,
32715 Pragma_Import_Object
=> 0,
32716 Pragma_Import_Procedure
=> 0,
32717 Pragma_Import_Valued_Procedure
=> 0,
32718 Pragma_Independent
=> 0,
32719 Pragma_Independent_Components
=> 0,
32720 Pragma_Initial_Condition
=> -1,
32721 Pragma_Initialize_Scalars
=> 0,
32722 Pragma_Initializes
=> -1,
32723 Pragma_Inline
=> 0,
32724 Pragma_Inline_Always
=> 0,
32725 Pragma_Inline_Generic
=> 0,
32726 Pragma_Inspection_Point
=> -1,
32727 Pragma_Interface
=> 92,
32728 Pragma_Interface_Name
=> 0,
32729 Pragma_Interrupt_Handler
=> -1,
32730 Pragma_Interrupt_Priority
=> -1,
32731 Pragma_Interrupt_State
=> -1,
32732 Pragma_Invariant
=> -1,
32733 Pragma_Keep_Names
=> 0,
32734 Pragma_License
=> 0,
32735 Pragma_Link_With
=> -1,
32736 Pragma_Linker_Alias
=> -1,
32737 Pragma_Linker_Constructor
=> -1,
32738 Pragma_Linker_Destructor
=> -1,
32739 Pragma_Linker_Options
=> -1,
32740 Pragma_Linker_Section
=> -1,
32742 Pragma_Lock_Free
=> 0,
32743 Pragma_Locking_Policy
=> 0,
32744 Pragma_Loop_Invariant
=> -1,
32745 Pragma_Loop_Optimize
=> 0,
32746 Pragma_Loop_Variant
=> -1,
32747 Pragma_Machine_Attribute
=> -1,
32749 Pragma_Main_Storage
=> -1,
32750 Pragma_Max_Entry_Queue_Depth
=> 0,
32751 Pragma_Max_Entry_Queue_Length
=> 0,
32752 Pragma_Max_Queue_Length
=> 0,
32753 Pragma_Memory_Size
=> 0,
32754 Pragma_No_Body
=> 0,
32755 Pragma_No_Caching
=> 0,
32756 Pragma_No_Component_Reordering
=> -1,
32757 Pragma_No_Elaboration_Code_All
=> 0,
32758 Pragma_No_Heap_Finalization
=> 0,
32759 Pragma_No_Inline
=> 0,
32760 Pragma_No_Return
=> 0,
32761 Pragma_No_Run_Time
=> -1,
32762 Pragma_No_Strict_Aliasing
=> -1,
32763 Pragma_No_Tagged_Streams
=> 0,
32764 Pragma_Normalize_Scalars
=> 0,
32765 Pragma_Obsolescent
=> 0,
32766 Pragma_Optimize
=> 0,
32767 Pragma_Optimize_Alignment
=> 0,
32768 Pragma_Ordered
=> 0,
32769 Pragma_Overflow_Mode
=> 0,
32770 Pragma_Overriding_Renamings
=> 0,
32773 Pragma_Part_Of
=> 0,
32774 Pragma_Partition_Elaboration_Policy
=> 0,
32775 Pragma_Passive
=> 0,
32776 Pragma_Persistent_BSS
=> 0,
32778 Pragma_Postcondition
=> -1,
32779 Pragma_Post_Class
=> -1,
32781 Pragma_Precondition
=> -1,
32782 Pragma_Predicate
=> -1,
32783 Pragma_Predicate_Failure
=> -1,
32784 Pragma_Preelaborable_Initialization
=> -1,
32785 Pragma_Preelaborate
=> 0,
32786 Pragma_Prefix_Exception_Messages
=> 0,
32787 Pragma_Pre_Class
=> -1,
32788 Pragma_Priority
=> -1,
32789 Pragma_Priority_Specific_Dispatching
=> 0,
32790 Pragma_Profile
=> 0,
32791 Pragma_Profile_Warnings
=> 0,
32792 Pragma_Propagate_Exceptions
=> 0,
32793 Pragma_Provide_Shift_Operators
=> 0,
32794 Pragma_Psect_Object
=> 0,
32796 Pragma_Pure_Function
=> 0,
32797 Pragma_Queuing_Policy
=> 0,
32798 Pragma_Rational
=> 0,
32799 Pragma_Ravenscar
=> 0,
32800 Pragma_Refined_Depends
=> -1,
32801 Pragma_Refined_Global
=> -1,
32802 Pragma_Refined_Post
=> -1,
32803 Pragma_Refined_State
=> 0,
32804 Pragma_Relative_Deadline
=> 0,
32805 Pragma_Remote_Access_Type
=> -1,
32806 Pragma_Remote_Call_Interface
=> -1,
32807 Pragma_Remote_Types
=> -1,
32808 Pragma_Rename_Pragma
=> 0,
32809 Pragma_Restricted_Run_Time
=> 0,
32810 Pragma_Restriction_Warnings
=> 0,
32811 Pragma_Restrictions
=> 0,
32812 Pragma_Reviewable
=> -1,
32813 Pragma_Side_Effects
=> 0,
32814 Pragma_Secondary_Stack_Size
=> -1,
32815 Pragma_Share_Generic
=> 0,
32816 Pragma_Shared
=> 0,
32817 Pragma_Shared_Passive
=> 0,
32818 Pragma_Short_Circuit_And_Or
=> 0,
32819 Pragma_Short_Descriptors
=> 0,
32820 Pragma_Simple_Storage_Pool_Type
=> 0,
32821 Pragma_Source_File_Name
=> 0,
32822 Pragma_Source_File_Name_Project
=> 0,
32823 Pragma_Source_Reference
=> 0,
32824 Pragma_SPARK_Mode
=> 0,
32825 Pragma_Static_Elaboration_Desired
=> 0,
32826 Pragma_Storage_Size
=> -1,
32827 Pragma_Storage_Unit
=> 0,
32828 Pragma_Stream_Convert
=> 0,
32829 Pragma_Style_Checks
=> 0,
32830 Pragma_Subprogram_Variant
=> -1,
32831 Pragma_Subtitle
=> 0,
32832 Pragma_Suppress
=> 0,
32833 Pragma_Suppress_All
=> 0,
32834 Pragma_Suppress_Debug_Info
=> 0,
32835 Pragma_Suppress_Exception_Locations
=> 0,
32836 Pragma_Suppress_Initialization
=> 0,
32837 Pragma_System_Name
=> 0,
32838 Pragma_Task_Dispatching_Policy
=> 0,
32839 Pragma_Task_Info
=> -1,
32840 Pragma_Task_Name
=> -1,
32841 Pragma_Task_Storage
=> -1,
32842 Pragma_Test_Case
=> -1,
32843 Pragma_Thread_Local_Storage
=> -1,
32844 Pragma_Time_Slice
=> -1,
32846 Pragma_Type_Invariant
=> -1,
32847 Pragma_Type_Invariant_Class
=> -1,
32848 Pragma_Unchecked_Union
=> 0,
32849 Pragma_Unevaluated_Use_Of_Old
=> 0,
32850 Pragma_Unimplemented_Unit
=> 0,
32851 Pragma_Universal_Aliasing
=> 0,
32852 Pragma_Unmodified
=> 0,
32853 Pragma_Unreferenced
=> 0,
32854 Pragma_Unreferenced_Objects
=> 0,
32855 Pragma_Unreserve_All_Interrupts
=> 0,
32856 Pragma_Unsuppress
=> 0,
32857 Pragma_Unused
=> 0,
32858 Pragma_Use_VADS_Size
=> 0,
32859 Pragma_User_Aspect_Definition
=> 0,
32860 Pragma_Validity_Checks
=> 0,
32861 Pragma_Volatile
=> 0,
32862 Pragma_Volatile_Components
=> 0,
32863 Pragma_Volatile_Full_Access
=> 0,
32864 Pragma_Volatile_Function
=> 0,
32865 Pragma_Warning_As_Error
=> 0,
32866 Pragma_Warnings
=> 0,
32867 Pragma_Weak_External
=> 0,
32868 Pragma_Wide_Character_Encoding
=> 0,
32869 Unknown_Pragma
=> 0);
32871 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
32877 function Arg_No
return Nat
;
32878 -- Returns an integer showing what argument we are in. A value of
32879 -- zero means we are not in any of the arguments.
32885 function Arg_No
return Nat
is
32890 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
32904 -- Start of processing for Non_Significant_Pragma_Reference
32907 -- Reference might appear either directly as expression of a pragma
32908 -- argument association, e.g. pragma Export (...), or within an
32909 -- aggregate with component associations, e.g. pragma Refined_State
32915 when N_Pragma_Argument_Association
=>
32917 when N_Aggregate | N_Component_Association
=>
32930 Id
:= Get_Pragma_Id
(Parent
(P
));
32931 C
:= Sig_Flags
(Id
);
32941 return AN
< (C
- 90);
32946 end Is_Non_Significant_Pragma_Reference
;
32948 ------------------------------
32949 -- Is_Pragma_String_Literal --
32950 ------------------------------
32952 -- This function returns true if the corresponding pragma argument is a
32953 -- static string expression. These are the only cases in which string
32954 -- literals can appear as pragma arguments. We also allow a string literal
32955 -- as the first argument to pragma Assert (although it will of course
32956 -- always generate a type error).
32958 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
32959 Pragn
: constant Node_Id
:= Parent
(Par
);
32960 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
32961 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
32967 N
:= First
(Assoc
);
32974 if Pname
= Name_Assert
then
32977 elsif Pname
= Name_Export
then
32980 elsif Pname
= Name_Ident
then
32983 elsif Pname
= Name_Import
then
32986 elsif Pname
= Name_Interface_Name
then
32989 elsif Pname
= Name_Linker_Alias
then
32992 elsif Pname
= Name_Linker_Section
then
32995 elsif Pname
= Name_Machine_Attribute
then
32998 elsif Pname
= Name_Source_File_Name
then
33001 elsif Pname
= Name_Source_Reference
then
33004 elsif Pname
= Name_Title
then
33007 elsif Pname
= Name_Subtitle
then
33013 end Is_Pragma_String_Literal
;
33015 ---------------------------
33016 -- Is_Private_SPARK_Mode --
33017 ---------------------------
33019 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
33022 (Nkind
(N
) = N_Pragma
33023 and then Pragma_Name
(N
) = Name_SPARK_Mode
33024 and then Is_List_Member
(N
));
33026 -- For pragma SPARK_Mode to be private, it has to appear in the private
33027 -- declarations of a package.
33030 Present
(Parent
(N
))
33031 and then Nkind
(Parent
(N
)) = N_Package_Specification
33032 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
33033 end Is_Private_SPARK_Mode
;
33035 -------------------------------------
33036 -- Is_Unconstrained_Or_Tagged_Item --
33037 -------------------------------------
33039 function Is_Unconstrained_Or_Tagged_Item
33040 (Item
: Entity_Id
) return Boolean
33042 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
33043 -- Determine whether record type Typ has at least one unconstrained
33046 ---------------------------------
33047 -- Has_Unconstrained_Component --
33048 ---------------------------------
33050 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
33054 Comp
:= First_Component
(Typ
);
33055 while Present
(Comp
) loop
33056 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
33060 Next_Component
(Comp
);
33064 end Has_Unconstrained_Component
;
33068 Typ
: constant Entity_Id
:= Etype
(Item
);
33070 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
33073 if Is_Tagged_Type
(Typ
) then
33076 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
33079 elsif Is_Record_Type
(Typ
) then
33080 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
33083 return Has_Unconstrained_Component
(Typ
);
33086 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
33092 end Is_Unconstrained_Or_Tagged_Item
;
33094 -----------------------------
33095 -- Is_Valid_Assertion_Kind --
33096 -----------------------------
33098 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
33105 | Name_Static_Predicate
33106 | Name_Dynamic_Predicate
33111 | Name_Type_Invariant
33112 | Name_uType_Invariant
33116 | Name_Assert_And_Cut
33118 | Name_Contract_Cases
33120 | Name_Default_Initial_Condition
33122 | Name_Ghost_Predicate
33123 | Name_Initial_Condition
33126 | Name_Loop_Invariant
33127 | Name_Loop_Variant
33128 | Name_Postcondition
33129 | Name_Precondition
33131 | Name_Refined_Post
33132 | Name_Statement_Assertions
33133 | Name_Subprogram_Variant
33140 end Is_Valid_Assertion_Kind
;
33142 --------------------------------------
33143 -- Process_Compilation_Unit_Pragmas --
33144 --------------------------------------
33146 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
33148 -- A special check for pragma Suppress_All, a very strange DEC pragma,
33149 -- strange because it comes at the end of the unit. Rational has the
33150 -- same name for a pragma, but treats it as a program unit pragma, In
33151 -- GNAT we just decide to allow it anywhere at all. If it appeared then
33152 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
33153 -- node, and we insert a pragma Suppress (All_Checks) at the start of
33154 -- the context clause to ensure the correct processing.
33156 if Has_Pragma_Suppress_All
(N
) then
33157 Prepend_To
(Context_Items
(N
),
33158 Make_Pragma
(Sloc
(N
),
33159 Chars
=> Name_Suppress
,
33160 Pragma_Argument_Associations
=> New_List
(
33161 Make_Pragma_Argument_Association
(Sloc
(N
),
33162 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
33165 -- Nothing else to do at the current time
33167 end Process_Compilation_Unit_Pragmas
;
33169 --------------------------------------------
33170 -- Validate_Compile_Time_Warning_Or_Error --
33171 --------------------------------------------
33173 procedure Validate_Compile_Time_Warning_Or_Error
33177 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33178 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
33179 Arg2
: constant Node_Id
:= Next
(Arg1
);
33181 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
33182 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
33185 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
33187 if Compile_Time_Known_Value
(Arg1x
) then
33188 if Is_True
(Expr_Value
(Arg1x
)) then
33190 -- We have already verified that the second argument is a static
33191 -- string expression. Its string value must be retrieved
33192 -- explicitly if it is a declared constant, otherwise it has
33193 -- been constant-folded previously.
33196 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
33197 Str
: constant String_Id
:=
33198 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
33199 Str_Len
: constant Nat
:= String_Length
(Str
);
33201 Force
: constant Boolean :=
33202 Prag_Id
= Pragma_Compile_Time_Warning
33203 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
33204 and then (Ekind
(Cent
) /= E_Package
33205 or else not In_Private_Part
(Cent
));
33206 -- Set True if this is the warning case, and we are in the
33207 -- visible part of a package spec, or in a subprogram spec,
33208 -- in which case we want to force the client to see the
33209 -- warning, even though it is not in the main unit.
33217 -- Loop through segments of message separated by line feeds.
33218 -- We output these segments as separate messages with
33219 -- continuation marks for all but the first.
33224 Error_Msg_Strlen
:= 0;
33226 -- Loop to copy characters from argument to error message
33230 exit when Ptr
> Str_Len
;
33231 CC
:= Get_String_Char
(Str
, Ptr
);
33234 -- Ignore wide chars ??? else store character
33236 if In_Character_Range
(CC
) then
33237 C
:= Get_Character
(CC
);
33238 exit when C
= ASCII
.LF
;
33239 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
33240 Error_Msg_String
(Error_Msg_Strlen
) := C
;
33244 -- Here with one line ready to go
33246 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
33248 -- If this is a warning in a spec, then we want clients
33249 -- to see the warning, so mark the message with the
33250 -- special sequence !! to force the warning. In the case
33251 -- of a package spec, we do not force this if we are in
33252 -- the private part of the spec.
33255 if Cont
= False then
33257 ("<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
33261 ("\<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
33264 -- Error, rather than warning, or in a body, so we do not
33265 -- need to force visibility for client (error will be
33266 -- output in any case, and this is the situation in which
33267 -- we do not want a client to get a warning, since the
33268 -- warning is in the body or the spec private part).
33271 if Cont
= False then
33273 ("<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
33277 ("\<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
33281 exit when Ptr
> Str_Len
;
33286 -- Arg1x is not known at compile time, so possibly issue an error
33287 -- or warning. This can happen only if the pragma's processing
33288 -- was deferred until after the back end is run (see
33289 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
33290 -- control switch applies to only the warning case.
33292 elsif Prag_Id
= Pragma_Compile_Time_Error
then
33293 Error_Msg_N
("condition is not known at compile time", Arg1x
);
33295 elsif Warn_On_Unknown_Compile_Time_Warning
then
33296 Error_Msg_N
("?_c?condition is not known at compile time", Arg1x
);
33298 end Validate_Compile_Time_Warning_Or_Error
;
33300 ------------------------------------
33301 -- Record_Possible_Body_Reference --
33302 ------------------------------------
33304 procedure Record_Possible_Body_Reference
33305 (State_Id
: Entity_Id
;
33309 Spec_Id
: Entity_Id
;
33312 -- Ensure that we are dealing with a reference to a state
33314 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
33316 -- Climb the tree starting from the reference looking for a package body
33317 -- whose spec declares the referenced state. This criteria automatically
33318 -- excludes references in package specs which are legal. Note that it is
33319 -- not wise to emit an error now as the package body may lack pragma
33320 -- Refined_State or the referenced state may not be mentioned in the
33321 -- refinement. This approach avoids the generation of misleading errors.
33324 while Present
(Context
) loop
33325 if Nkind
(Context
) = N_Package_Body
then
33326 Spec_Id
:= Corresponding_Spec
(Context
);
33328 if Contains
(Abstract_States
(Spec_Id
), State_Id
) then
33329 if No
(Body_References
(State_Id
)) then
33330 Set_Body_References
(State_Id
, New_Elmt_List
);
33333 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
33338 Context
:= Parent
(Context
);
33340 end Record_Possible_Body_Reference
;
33342 ------------------------------------------
33343 -- Relocate_Pragmas_To_Anonymous_Object --
33344 ------------------------------------------
33346 procedure Relocate_Pragmas_To_Anonymous_Object
33347 (Typ_Decl
: Node_Id
;
33348 Obj_Decl
: Node_Id
)
33352 Next_Decl
: Node_Id
;
33355 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
33356 Def
:= Protected_Definition
(Typ_Decl
);
33358 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
33359 Def
:= Task_Definition
(Typ_Decl
);
33362 -- The concurrent definition has a visible declaration list. Inspect it
33363 -- and relocate all canidate pragmas.
33365 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
33366 Decl
:= First
(Visible_Declarations
(Def
));
33367 while Present
(Decl
) loop
33369 -- Preserve the following declaration for iteration purposes due
33370 -- to possible relocation of a pragma.
33372 Next_Decl
:= Next
(Decl
);
33374 if Nkind
(Decl
) = N_Pragma
33375 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
33378 Insert_After
(Obj_Decl
, Decl
);
33380 -- Skip internally generated code
33382 elsif not Comes_From_Source
(Decl
) then
33385 -- No candidate pragmas are available for relocation
33394 end Relocate_Pragmas_To_Anonymous_Object
;
33396 ------------------------------
33397 -- Relocate_Pragmas_To_Body --
33398 ------------------------------
33400 procedure Relocate_Pragmas_To_Body
33401 (Subp_Body
: Node_Id
;
33402 Target_Body
: Node_Id
:= Empty
)
33404 procedure Relocate_Pragma
(Prag
: Node_Id
);
33405 -- Remove a single pragma from its current list and add it to the
33406 -- declarations of the proper body (either Subp_Body or Target_Body).
33408 ---------------------
33409 -- Relocate_Pragma --
33410 ---------------------
33412 procedure Relocate_Pragma
(Prag
: Node_Id
) is
33417 -- When subprogram stubs or expression functions are involves, the
33418 -- destination declaration list belongs to the proper body.
33420 if Present
(Target_Body
) then
33421 Target
:= Target_Body
;
33423 Target
:= Subp_Body
;
33426 Decls
:= Declarations
(Target
);
33430 Set_Declarations
(Target
, Decls
);
33433 -- Unhook the pragma from its current list
33436 Prepend
(Prag
, Decls
);
33437 end Relocate_Pragma
;
33441 Body_Id
: constant Entity_Id
:=
33442 Defining_Unit_Name
(Specification
(Subp_Body
));
33443 Next_Stmt
: Node_Id
;
33446 -- Start of processing for Relocate_Pragmas_To_Body
33449 -- Do not process a body that comes from a separate unit as no construct
33450 -- can possibly follow it.
33452 if not Is_List_Member
(Subp_Body
) then
33455 -- Do not relocate pragmas that follow a stub if the stub does not have
33458 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
33459 and then No
(Target_Body
)
33463 -- Do not process internally generated routine _Wrapped_Statements
33465 elsif Ekind
(Body_Id
) = E_Procedure
33466 and then Chars
(Body_Id
) = Name_uWrapped_Statements
33471 -- Look at what is following the body. We are interested in certain kind
33472 -- of pragmas (either from source or byproducts of expansion) that can
33473 -- apply to a body [stub].
33475 Stmt
:= Next
(Subp_Body
);
33476 while Present
(Stmt
) loop
33478 -- Preserve the following statement for iteration purposes due to a
33479 -- possible relocation of a pragma.
33481 Next_Stmt
:= Next
(Stmt
);
33483 -- Move a candidate pragma following the body to the declarations of
33486 if Nkind
(Stmt
) = N_Pragma
33487 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
33490 -- If a source pragma Warnings follows the body, it applies to
33491 -- following statements and does not belong in the body.
33493 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
33494 and then Comes_From_Source
(Stmt
)
33498 Relocate_Pragma
(Stmt
);
33501 -- Skip internally generated code
33503 elsif not Comes_From_Source
(Stmt
) then
33506 -- No candidate pragmas are available for relocation
33514 end Relocate_Pragmas_To_Body
;
33516 -------------------
33517 -- Resolve_State --
33518 -------------------
33520 procedure Resolve_State
(N
: Node_Id
) is
33525 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
33526 Func
:= Entity
(N
);
33528 -- Handle overloading of state names by functions. Traverse the
33529 -- homonym chain looking for an abstract state.
33531 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
33532 pragma Assert
(Is_Overloaded
(N
));
33534 State
:= Homonym
(Func
);
33535 while Present
(State
) loop
33536 if Ekind
(State
) = E_Abstract_State
then
33538 -- Resolve the overloading by setting the proper entity of
33539 -- the reference to that of the state.
33541 Set_Etype
(N
, Standard_Void_Type
);
33542 Set_Entity
(N
, State
);
33543 Set_Is_Overloaded
(N
, False);
33545 Generate_Reference
(State
, N
);
33549 State
:= Homonym
(State
);
33552 -- A function can never act as a state. If the homonym chain does
33553 -- not contain a corresponding state, then something went wrong in
33554 -- the overloading mechanism.
33556 raise Program_Error
;
33561 ----------------------------
33562 -- Rewrite_Assertion_Kind --
33563 ----------------------------
33565 procedure Rewrite_Assertion_Kind
33567 From_Policy
: Boolean := False)
33573 if Nkind
(N
) = N_Attribute_Reference
33574 and then Attribute_Name
(N
) = Name_Class
33575 and then Nkind
(Prefix
(N
)) = N_Identifier
33577 case Chars
(Prefix
(N
)) is
33584 when Name_Type_Invariant
=>
33585 Nam
:= Name_uType_Invariant
;
33587 when Name_Invariant
=>
33588 Nam
:= Name_uInvariant
;
33594 -- Recommend standard use of aspect names Pre/Post
33596 elsif Nkind
(N
) = N_Identifier
33597 and then From_Policy
33598 and then Serious_Errors_Detected
= 0
33600 if Chars
(N
) = Name_Precondition
33601 or else Chars
(N
) = Name_Postcondition
33603 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
33605 ("\use Assertion_Policy and aspect names Pre/Post for "
33606 & "Ada2012 conformance?", N
);
33612 if Nam
/= No_Name
then
33613 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
33615 end Rewrite_Assertion_Kind
;
33623 Dummy
:= Dummy
+ 1;
33626 --------------------------------
33627 -- Set_Encoded_Interface_Name --
33628 --------------------------------
33630 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
33631 Str
: constant String_Id
:= Strval
(S
);
33632 Len
: constant Nat
:= String_Length
(Str
);
33637 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
33640 -- Stores encoded value of character code CC. The encoding we use an
33641 -- underscore followed by four lower case hex digits.
33647 procedure Encode
is
33649 Store_String_Char
(Get_Char_Code
('_'));
33651 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
33653 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
33655 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
33657 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
33660 -- Start of processing for Set_Encoded_Interface_Name
33663 -- If first character is asterisk, this is a link name, and we leave it
33664 -- completely unmodified. We also ignore null strings (the latter case
33665 -- happens only in error cases).
33668 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
33670 Set_Interface_Name
(E
, S
);
33675 CC
:= Get_String_Char
(Str
, J
);
33677 exit when not In_Character_Range
(CC
);
33679 C
:= Get_Character
(CC
);
33681 exit when C
/= '_' and then C
/= '$'
33682 and then C
not in '0' .. '9'
33683 and then C
not in 'a' .. 'z'
33684 and then C
not in 'A' .. 'Z';
33687 Set_Interface_Name
(E
, S
);
33695 -- Here we need to encode. The encoding we use as follows:
33696 -- three underscores + four hex digits (lower case)
33700 for J
in 1 .. String_Length
(Str
) loop
33701 CC
:= Get_String_Char
(Str
, J
);
33703 if not In_Character_Range
(CC
) then
33706 C
:= Get_Character
(CC
);
33708 if C
= '_' or else C
= '$'
33709 or else C
in '0' .. '9'
33710 or else C
in 'a' .. 'z'
33711 or else C
in 'A' .. 'Z'
33713 Store_String_Char
(CC
);
33720 Set_Interface_Name
(E
,
33721 Make_String_Literal
(Sloc
(S
),
33722 Strval
=> End_String
));
33724 end Set_Encoded_Interface_Name
;
33726 ------------------------
33727 -- Set_Elab_Unit_Name --
33728 ------------------------
33730 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
33735 if Nkind
(N
) = N_Identifier
33736 and then Nkind
(With_Item
) = N_Identifier
33738 Set_Entity
(N
, Entity
(With_Item
));
33740 elsif Nkind
(N
) = N_Selected_Component
then
33741 Change_Selected_Component_To_Expanded_Name
(N
);
33742 Set_Entity
(N
, Entity
(With_Item
));
33743 Set_Entity
(Selector_Name
(N
), Entity
(N
));
33745 Pref
:= Prefix
(N
);
33746 Scop
:= Scope
(Entity
(N
));
33747 while Nkind
(Pref
) = N_Selected_Component
loop
33748 Change_Selected_Component_To_Expanded_Name
(Pref
);
33749 Set_Entity
(Selector_Name
(Pref
), Scop
);
33750 Set_Entity
(Pref
, Scop
);
33751 Pref
:= Prefix
(Pref
);
33752 Scop
:= Scope
(Scop
);
33755 Set_Entity
(Pref
, Scop
);
33758 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
33759 end Set_Elab_Unit_Name
;
33761 -----------------------
33762 -- Set_Overflow_Mode --
33763 -----------------------
33765 procedure Set_Overflow_Mode
(N
: Node_Id
) is
33767 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
;
33768 -- Function to process one pragma argument, Arg
33770 -----------------------
33771 -- Get_Overflow_Mode --
33772 -----------------------
33774 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
is
33775 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
33778 if Chars
(Argx
) = Name_Strict
then
33781 elsif Chars
(Argx
) = Name_Minimized
then
33784 elsif Chars
(Argx
) = Name_Eliminated
then
33788 raise Program_Error
;
33790 end Get_Overflow_Mode
;
33794 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33795 Arg2
: constant Node_Id
:= Next
(Arg1
);
33797 -- Start of processing for Set_Overflow_Mode
33800 -- Process first argument
33802 Scope_Suppress
.Overflow_Mode_General
:=
33803 Get_Overflow_Mode
(Arg1
);
33805 -- Case of only one argument
33808 Scope_Suppress
.Overflow_Mode_Assertions
:=
33809 Scope_Suppress
.Overflow_Mode_General
;
33811 -- Case of two arguments present
33814 Scope_Suppress
.Overflow_Mode_Assertions
:=
33815 Get_Overflow_Mode
(Arg2
);
33817 end Set_Overflow_Mode
;
33819 -------------------
33820 -- Test_Case_Arg --
33821 -------------------
33823 function Test_Case_Arg
33826 From_Aspect
: Boolean := False) return Node_Id
33828 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
33834 (Arg_Nam
in Name_Ensures | Name_Mode | Name_Name | Name_Requires
);
33836 -- The caller requests the aspect argument
33838 if From_Aspect
then
33839 if Present
(Aspect
)
33840 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
33842 Args
:= Expression
(Aspect
);
33844 -- "Name" and "Mode" may appear without an identifier as a
33845 -- positional association.
33847 if Present
(Expressions
(Args
)) then
33848 Arg
:= First
(Expressions
(Args
));
33850 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
33858 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
33863 -- Some or all arguments may appear as component associatons
33865 if Present
(Component_Associations
(Args
)) then
33866 Arg
:= First
(Component_Associations
(Args
));
33867 while Present
(Arg
) loop
33868 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
33877 -- Otherwise retrieve the argument directly from the pragma
33880 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
33882 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
33886 -- Skip argument "Name"
33890 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
33894 -- Skip argument "Mode"
33898 -- Arguments "Requires" and "Ensures" are optional and may not be
33901 while Present
(Arg
) loop
33902 if Chars
(Arg
) = Arg_Nam
then
33913 --------------------------------------------
33914 -- Defer_Compile_Time_Warning_Error_To_BE --
33915 --------------------------------------------
33917 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
) is
33918 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
33920 Compile_Time_Warnings_Errors
.Append
33921 (New_Val
=> CTWE_Entry
'(Eloc => Sloc (Arg1),
33922 Scope => Current_Scope,
33925 -- If the Boolean expression contains T'Size, and we're not in the main
33926 -- unit being compiled, then we need to copy the pragma into the main
33927 -- unit, because otherwise T'Size might never be computed, leaving it
33930 if not In_Extended_Main_Code_Unit (N) then
33931 Insert_Library_Level_Action (New_Copy_Tree (N));
33933 end Defer_Compile_Time_Warning_Error_To_BE;
33935 ------------------------------------------
33936 -- Validate_Compile_Time_Warning_Errors --
33937 ------------------------------------------
33939 procedure Validate_Compile_Time_Warning_Errors is
33940 procedure Set_Scope (S : Entity_Id);
33941 -- Install all enclosing scopes of S along with S itself
33943 procedure Unset_Scope (S : Entity_Id);
33944 -- Uninstall all enclosing scopes of S along with S itself
33950 procedure Set_Scope (S : Entity_Id) is
33952 if S /= Standard_Standard then
33953 Set_Scope (Scope (S));
33963 procedure Unset_Scope (S : Entity_Id) is
33965 if S /= Standard_Standard then
33966 Unset_Scope (Scope (S));
33972 -- Start of processing for Validate_Compile_Time_Warning_Errors
33975 Expander_Mode_Save_And_Set (False);
33976 In_Compile_Time_Warning_Or_Error := True;
33978 for N in Compile_Time_Warnings_Errors.First ..
33979 Compile_Time_Warnings_Errors.Last
33982 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
33985 Set_Scope (T.Scope);
33986 Reset_Analyzed_Flags (T.Prag);
33987 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
33988 Unset_Scope (T.Scope);
33992 In_Compile_Time_Warning_Or_Error := False;
33993 Expander_Mode_Restore;
33994 end Validate_Compile_Time_Warning_Errors;