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_Part_Of
193 Encap_Id
: out Entity_Id
;
194 Legal
: out Boolean);
195 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
196 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
197 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
198 -- package instantiation. Encap denotes the encapsulating state or single
199 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
200 -- the indicator is legal.
202 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
203 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
204 -- Query whether a particular item appears in a mixed list of nodes and
205 -- entities. It is assumed that all nodes in the list have entities.
207 procedure Check_Postcondition_Use_In_Inlined_Subprogram
209 Spec_Id
: Entity_Id
);
210 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
211 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
212 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
213 -- and assertions are enabled.
215 procedure Check_State_And_Constituent_Use
219 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
220 -- Global and Initializes. Determine whether a state from list States and a
221 -- corresponding constituent from list Constits (if any) appear in the same
222 -- context denoted by Context. If this is the case, emit an error.
224 procedure Contract_Freeze_Error
225 (Contract_Id
: Entity_Id
;
226 Freeze_Id
: Entity_Id
);
227 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
228 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
229 -- of a body which caused contract freezing and Contract_Id denotes the
230 -- entity of the affected contstruct.
232 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
233 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
234 -- Prag that duplicates previous pragma Prev.
236 function Find_Encapsulating_State
238 Constit_Id
: Entity_Id
) return Entity_Id
;
239 -- Given the entity of a constituent Constit_Id, find the corresponding
240 -- encapsulating state which appears in States. The routine returns Empty
241 -- if no such state is found.
243 function Find_Related_Context
245 Do_Checks
: Boolean := False) return Node_Id
;
246 -- Subsidiary to the analysis of pragmas
249 -- Constant_After_Elaboration
254 -- Find the first source declaration or statement found while traversing
255 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
256 -- set, the routine reports duplicate pragmas. The routine returns Empty
257 -- when reaching the start of the node chain.
259 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
260 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
261 -- original one, following the renaming chain) is returned. Otherwise the
262 -- entity is returned unchanged. Should be in Einfo???
264 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
265 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
266 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
267 -- value of type SPARK_Mode_Type.
269 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
270 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
271 -- Determine whether dependency clause Clause is surrounded by extra
272 -- parentheses. If this is the case, issue an error message.
274 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
275 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
276 -- pragma Depends. Determine whether the type of dependency item Item is
277 -- tagged, unconstrained array, unconstrained record or a record with at
278 -- least one unconstrained component.
280 procedure Record_Possible_Body_Reference
281 (State_Id
: Entity_Id
;
283 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
284 -- Global. Given an abstract state denoted by State_Id and a reference Ref
285 -- to it, determine whether the reference appears in a package body that
286 -- will eventually refine the state. If this is the case, record the
287 -- reference for future checks (see Analyze_Refined_State_In_Decls).
289 procedure Resolve_State
(N
: Node_Id
);
290 -- Handle the overloading of state names by functions. When N denotes a
291 -- function, this routine finds the corresponding state and sets the entity
292 -- of N to that of the state.
294 procedure Rewrite_Assertion_Kind
296 From_Policy
: Boolean := False);
297 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
298 -- then it is rewritten as an identifier with the corresponding special
299 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
300 -- and Check_Policy. If the names are Precondition or Postcondition, this
301 -- combination is deprecated in favor of Assertion_Policy and Ada2012
302 -- Aspect names. The parameter From_Policy indicates that the pragma
303 -- is the old non-standard Check_Policy and not a rewritten pragma.
305 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
306 -- Place semantic information on the argument of an Elaborate/Elaborate_All
307 -- pragma. Entity name for unit and its parents is taken from item in
308 -- previous with_clause that mentions the unit.
310 procedure Validate_Compile_Time_Warning_Or_Error
313 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
314 -- pragma N. Called when the pragma is processed as part of its regular
315 -- analysis but also called after calling the back end to validate these
316 -- pragmas for size and alignment appropriateness.
318 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
);
319 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
320 -- expression is not known at compile time during the front end. This
321 -- procedure makes an entry in a table. The actual checking is performed by
322 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
325 Dummy
: Integer := 0;
326 pragma Volatile
(Dummy
);
327 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
330 pragma No_Inline
(ip
);
331 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
332 -- is just to help debugging the front end. If a pragma Inspection_Point
333 -- is added to a source program, then breaking on ip will get you to that
334 -- point in the program.
337 pragma No_Inline
(rv
);
338 -- This is a dummy function called by the processing for pragma Reviewable.
339 -- It is there for assisting front end debugging. By placing a Reviewable
340 -- pragma in the source program, a breakpoint on rv catches this place in
341 -- the source, allowing convenient stepping to the point of interest.
343 ------------------------------------------------------
344 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
345 ------------------------------------------------------
347 -- The following table collects pragmas Compile_Time_Error and Compile_
348 -- Time_Warning for validation. Entries are made by calls to subprogram
349 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
350 -- Validate_Compile_Time_Warning_Errors does the actual error checking
351 -- and posting of warning and error messages. The reason for this delayed
352 -- processing is to take advantage of back-annotations of attributes size
353 -- and alignment values performed by the back end.
355 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
356 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
357 -- will already have modified all Sloc values if the -gnatD option is set.
359 type CTWE_Entry
is record
361 -- Source location used in warnings and error messages
364 -- Pragma Compile_Time_Error or Compile_Time_Warning
367 -- The scope which encloses the pragma
370 package Compile_Time_Warnings_Errors
is new Table
.Table
(
371 Table_Component_Type
=> CTWE_Entry
,
372 Table_Index_Type
=> Int
,
373 Table_Low_Bound
=> 1,
375 Table_Increment
=> 200,
376 Table_Name
=> "Compile_Time_Warnings_Errors");
378 -------------------------------
379 -- Adjust_External_Name_Case --
380 -------------------------------
382 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
386 -- Adjust case of literal if required
388 if Opt
.External_Name_Exp_Casing
= As_Is
then
392 -- Copy existing string
398 for J
in 1 .. String_Length
(Strval
(N
)) loop
399 CC
:= Get_String_Char
(Strval
(N
), J
);
401 if Opt
.External_Name_Exp_Casing
= Uppercase
402 and then CC
in Get_Char_Code
('a') .. Get_Char_Code
('z')
404 Store_String_Char
(CC
- 32);
406 elsif Opt
.External_Name_Exp_Casing
= Lowercase
407 and then CC
in Get_Char_Code
('A') .. Get_Char_Code
('Z')
409 Store_String_Char
(CC
+ 32);
412 Store_String_Char
(CC
);
417 Make_String_Literal
(Sloc
(N
),
418 Strval
=> End_String
);
420 end Adjust_External_Name_Case
;
422 -----------------------------------------
423 -- Analyze_Contract_Cases_In_Decl_Part --
424 -----------------------------------------
426 -- WARNING: This routine manages Ghost regions. Return statements must be
427 -- replaced by gotos which jump to the end of the routine and restore the
430 procedure Analyze_Contract_Cases_In_Decl_Part
432 Freeze_Id
: Entity_Id
:= Empty
)
434 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
435 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
437 Others_Seen
: Boolean := False;
438 -- This flag is set when an "others" choice is encountered. It is used
439 -- to detect multiple illegal occurrences of "others".
441 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
442 -- Verify the legality of a single contract case
444 ---------------------------
445 -- Analyze_Contract_Case --
446 ---------------------------
448 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
449 Case_Guard
: Node_Id
;
452 Extra_Guard
: Node_Id
;
455 if Nkind
(CCase
) = N_Component_Association
then
456 Case_Guard
:= First
(Choices
(CCase
));
457 Conseq
:= Expression
(CCase
);
459 -- Each contract case must have exactly one case guard
461 Extra_Guard
:= Next
(Case_Guard
);
463 if Present
(Extra_Guard
) then
465 ("contract case must have exactly one case guard",
469 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
471 if Nkind
(Case_Guard
) = N_Others_Choice
then
474 ("only one OTHERS choice allowed in contract cases",
480 elsif Others_Seen
then
482 ("OTHERS must be the last choice in contract cases", N
);
485 -- Preanalyze the case guard and consequence
487 if Nkind
(Case_Guard
) /= N_Others_Choice
then
488 Errors
:= Serious_Errors_Detected
;
489 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
491 -- Emit a clarification message when the case guard contains
492 -- at least one undefined reference, possibly due to contract
495 if Errors
/= Serious_Errors_Detected
496 and then Present
(Freeze_Id
)
497 and then Has_Undefined_Reference
(Case_Guard
)
499 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
503 Errors
:= Serious_Errors_Detected
;
504 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
506 -- Emit a clarification message when the consequence contains
507 -- at least one undefined reference, possibly due to contract
510 if Errors
/= Serious_Errors_Detected
511 and then Present
(Freeze_Id
)
512 and then Has_Undefined_Reference
(Conseq
)
514 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
517 -- The contract case is malformed
520 Error_Msg_N
("wrong syntax in contract case", CCase
);
522 end Analyze_Contract_Case
;
526 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
528 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
529 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
530 -- Save the Ghost-related attributes to restore on exit
533 Restore_Scope
: Boolean := False;
535 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
538 -- Do not analyze the pragma multiple times
540 if Is_Analyzed_Pragma
(N
) then
544 -- Set the Ghost mode in effect from the pragma. Due to the delayed
545 -- analysis of the pragma, the Ghost mode at point of declaration and
546 -- point of analysis may not necessarily be the same. Use the mode in
547 -- effect at the point of declaration.
551 -- Single and multiple contract cases must appear in aggregate form. If
552 -- this is not the case, then either the parser or the analysis of the
553 -- pragma failed to produce an aggregate, e.g. when the contract is
554 -- "null" or a "(null record)".
557 (if Nkind
(CCases
) = N_Aggregate
558 then Null_Record_Present
(CCases
)
559 xor (Present
(Component_Associations
(CCases
))
561 Present
(Expressions
(CCases
)))
562 else Nkind
(CCases
) = N_Null
);
564 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
566 if Nkind
(CCases
) = N_Aggregate
567 and then Present
(Component_Associations
(CCases
))
568 and then No
(Expressions
(CCases
))
571 -- Check that the expression is a proper aggregate (no parentheses)
573 if Paren_Count
(CCases
) /= 0 then
574 Error_Msg_F
-- CODEFIX
575 ("redundant parentheses", CCases
);
578 -- Ensure that the formal parameters are visible when analyzing all
579 -- clauses. This falls out of the general rule of aspects pertaining
580 -- to subprogram declarations.
582 if not In_Open_Scopes
(Spec_Id
) then
583 Restore_Scope
:= True;
584 Push_Scope
(Spec_Id
);
586 if Is_Generic_Subprogram
(Spec_Id
) then
587 Install_Generic_Formals
(Spec_Id
);
589 Install_Formals
(Spec_Id
);
593 CCase
:= First
(Component_Associations
(CCases
));
594 while Present
(CCase
) loop
595 Analyze_Contract_Case
(CCase
);
599 if Restore_Scope
then
603 -- Currently it is not possible to inline pre/postconditions on a
604 -- subprogram subject to pragma Inline_Always.
606 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
608 -- Otherwise the pragma is illegal
611 Error_Msg_N
("wrong syntax for contract cases", N
);
614 Set_Is_Analyzed_Pragma
(N
);
616 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
617 end Analyze_Contract_Cases_In_Decl_Part
;
619 ----------------------------------
620 -- Analyze_Depends_In_Decl_Part --
621 ----------------------------------
623 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
624 Loc
: constant Source_Ptr
:= Sloc
(N
);
625 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
626 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
628 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
629 -- A list containing the entities of all the inputs processed so far.
630 -- The list is populated with unique entities because the same input
631 -- may appear in multiple input lists.
633 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
634 -- A list containing the entities of all the outputs processed so far.
635 -- The list is populated with unique entities because output items are
636 -- unique in a dependence relation.
638 Constits_Seen
: Elist_Id
:= No_Elist
;
639 -- A list containing the entities of all constituents processed so far.
640 -- It aids in detecting illegal usage of a state and a corresponding
641 -- constituent in pragma [Refinde_]Depends.
643 Global_Seen
: Boolean := False;
644 -- A flag set when pragma Global has been processed
646 Null_Output_Seen
: Boolean := False;
647 -- A flag used to track the legality of a null output
649 Result_Seen
: Boolean := False;
650 -- A flag set when Spec_Id'Result is processed
652 States_Seen
: Elist_Id
:= No_Elist
;
653 -- A list containing the entities of all states processed so far. It
654 -- helps in detecting illegal usage of a state and a corresponding
655 -- constituent in pragma [Refined_]Depends.
657 Subp_Inputs
: Elist_Id
:= No_Elist
;
658 Subp_Outputs
: Elist_Id
:= No_Elist
;
659 -- Two lists containing the full set of inputs and output of the related
660 -- subprograms. Note that these lists contain both nodes and entities.
662 Task_Input_Seen
: Boolean := False;
663 Task_Output_Seen
: Boolean := False;
664 -- Flags used to track the implicit dependence of a task unit on itself
666 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
667 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
668 -- to the name buffer. The individual kinds are as follows:
669 -- E_Abstract_State - "state"
670 -- E_Constant - "constant"
671 -- E_Generic_In_Out_Parameter - "generic parameter"
672 -- E_Generic_In_Parameter - "generic parameter"
673 -- E_In_Parameter - "parameter"
674 -- E_In_Out_Parameter - "parameter"
675 -- E_Loop_Parameter - "loop parameter"
676 -- E_Out_Parameter - "parameter"
677 -- E_Protected_Type - "current instance of protected type"
678 -- E_Task_Type - "current instance of task type"
679 -- E_Variable - "global"
681 procedure Analyze_Dependency_Clause
684 -- Verify the legality of a single dependency clause. Flag Is_Last
685 -- denotes whether Clause is the last clause in the relation.
687 procedure Check_Function_Return
;
688 -- Verify that Funtion'Result appears as one of the outputs
689 -- (SPARK RM 6.1.5(10)).
696 -- Ensure that an item fulfills its designated input and/or output role
697 -- as specified by pragma Global (if any) or the enclosing context. If
698 -- this is not the case, emit an error. Item and Item_Id denote the
699 -- attributes of an item. Flag Is_Input should be set when item comes
700 -- from an input list. Flag Self_Ref should be set when the item is an
701 -- output and the dependency clause has operator "+".
703 procedure Check_Usage
704 (Subp_Items
: Elist_Id
;
705 Used_Items
: Elist_Id
;
707 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
708 -- error if this is not the case.
710 procedure Normalize_Clause
(Clause
: Node_Id
);
711 -- Remove a self-dependency "+" from the input list of a clause
713 -----------------------------
714 -- Add_Item_To_Name_Buffer --
715 -----------------------------
717 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
719 if Ekind
(Item_Id
) = E_Abstract_State
then
720 Add_Str_To_Name_Buffer
("state");
722 elsif Ekind
(Item_Id
) = E_Constant
then
723 Add_Str_To_Name_Buffer
("constant");
725 elsif Is_Formal_Object
(Item_Id
) then
726 Add_Str_To_Name_Buffer
("generic parameter");
728 elsif Is_Formal
(Item_Id
) then
729 Add_Str_To_Name_Buffer
("parameter");
731 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
732 Add_Str_To_Name_Buffer
("loop parameter");
734 elsif Ekind
(Item_Id
) = E_Protected_Type
735 or else Is_Single_Protected_Object
(Item_Id
)
737 Add_Str_To_Name_Buffer
("current instance of protected type");
739 elsif Ekind
(Item_Id
) = E_Task_Type
740 or else Is_Single_Task_Object
(Item_Id
)
742 Add_Str_To_Name_Buffer
("current instance of task type");
744 elsif Ekind
(Item_Id
) = E_Variable
then
745 Add_Str_To_Name_Buffer
("global");
747 -- The routine should not be called with non-SPARK items
752 end Add_Item_To_Name_Buffer
;
754 -------------------------------
755 -- Analyze_Dependency_Clause --
756 -------------------------------
758 procedure Analyze_Dependency_Clause
762 procedure Analyze_Input_List
(Inputs
: Node_Id
);
763 -- Verify the legality of a single input list
765 procedure Analyze_Input_Output
770 Seen
: in out Elist_Id
;
771 Null_Seen
: in out Boolean;
772 Non_Null_Seen
: in out Boolean);
773 -- Verify the legality of a single input or output item. Flag
774 -- Is_Input should be set whenever Item is an input, False when it
775 -- denotes an output. Flag Self_Ref should be set when the item is an
776 -- output and the dependency clause has a "+". Flag Top_Level should
777 -- be set whenever Item appears immediately within an input or output
778 -- list. Seen is a collection of all abstract states, objects and
779 -- formals processed so far. Flag Null_Seen denotes whether a null
780 -- input or output has been encountered. Flag Non_Null_Seen denotes
781 -- whether a non-null input or output has been encountered.
783 ------------------------
784 -- Analyze_Input_List --
785 ------------------------
787 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
788 Inputs_Seen
: Elist_Id
:= No_Elist
;
789 -- A list containing the entities of all inputs that appear in the
790 -- current input list.
792 Non_Null_Input_Seen
: Boolean := False;
793 Null_Input_Seen
: Boolean := False;
794 -- Flags used to check the legality of an input list
799 -- Multiple inputs appear as an aggregate
801 if Nkind
(Inputs
) = N_Aggregate
then
802 if Present
(Component_Associations
(Inputs
)) then
804 ("nested dependency relations not allowed", Inputs
);
806 elsif Present
(Expressions
(Inputs
)) then
807 Input
:= First
(Expressions
(Inputs
));
808 while Present
(Input
) loop
815 Null_Seen
=> Null_Input_Seen
,
816 Non_Null_Seen
=> Non_Null_Input_Seen
);
821 -- Syntax error, always report
824 Error_Msg_N
("malformed input dependency list", Inputs
);
827 -- Process a solitary input
836 Null_Seen
=> Null_Input_Seen
,
837 Non_Null_Seen
=> Non_Null_Input_Seen
);
840 -- Detect an illegal dependency clause of the form
844 if Null_Output_Seen
and then Null_Input_Seen
then
846 ("null dependency clause cannot have a null input list",
849 end Analyze_Input_List
;
851 --------------------------
852 -- Analyze_Input_Output --
853 --------------------------
855 procedure Analyze_Input_Output
860 Seen
: in out Elist_Id
;
861 Null_Seen
: in out Boolean;
862 Non_Null_Seen
: in out Boolean)
864 procedure Current_Task_Instance_Seen
;
865 -- Set the appropriate global flag when the current instance of a
866 -- task unit is encountered.
868 --------------------------------
869 -- Current_Task_Instance_Seen --
870 --------------------------------
872 procedure Current_Task_Instance_Seen
is
875 Task_Input_Seen
:= True;
877 Task_Output_Seen
:= True;
879 end Current_Task_Instance_Seen
;
883 Is_Output
: constant Boolean := not Is_Input
;
887 -- Start of processing for Analyze_Input_Output
890 -- Multiple input or output items appear as an aggregate
892 if Nkind
(Item
) = N_Aggregate
then
893 if not Top_Level
then
894 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
896 elsif Present
(Component_Associations
(Item
)) then
898 ("nested dependency relations not allowed", Item
);
900 -- Recursively analyze the grouped items
902 elsif Present
(Expressions
(Item
)) then
903 Grouped
:= First
(Expressions
(Item
));
904 while Present
(Grouped
) loop
907 Is_Input
=> Is_Input
,
908 Self_Ref
=> Self_Ref
,
911 Null_Seen
=> Null_Seen
,
912 Non_Null_Seen
=> Non_Null_Seen
);
917 -- Syntax error, always report
920 Error_Msg_N
("malformed dependency list", Item
);
923 -- Process attribute 'Result in the context of a dependency clause
925 elsif Is_Attribute_Result
(Item
) then
926 Non_Null_Seen
:= True;
930 -- Attribute 'Result is allowed to appear on the output side of
931 -- a dependency clause (SPARK RM 6.1.5(6)).
934 SPARK_Msg_N
("function result cannot act as input", Item
);
938 ("cannot mix null and non-null dependency items", Item
);
944 -- Detect multiple uses of null in a single dependency list or
945 -- throughout the whole relation. Verify the placement of a null
946 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
948 elsif Nkind
(Item
) = N_Null
then
951 ("multiple null dependency relations not allowed", Item
);
953 elsif Non_Null_Seen
then
955 ("cannot mix null and non-null dependency items", Item
);
963 ("null output list must be the last clause in a "
964 & "dependency relation", Item
);
966 -- Catch a useless dependence of the form:
971 ("useless dependence, null depends on itself", Item
);
979 Non_Null_Seen
:= True;
982 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
986 Resolve_State
(Item
);
988 -- Find the entity of the item. If this is a renaming, climb
989 -- the renaming chain to reach the root object. Renamings of
990 -- non-entire objects do not yield an entity (Empty).
992 Item_Id
:= Entity_Of
(Item
);
994 if Present
(Item_Id
) then
998 if Ekind
(Item_Id
) in E_Constant | E_Loop_Parameter
1001 -- Current instances of concurrent types
1003 Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
1006 -- Formal parameters
1008 Ekind
(Item_Id
) in E_Generic_In_Out_Parameter
1009 | E_Generic_In_Parameter
1011 | E_In_Out_Parameter
1015 -- States, variables
1017 Ekind
(Item_Id
) in E_Abstract_State | E_Variable
1019 -- A [generic] function is not allowed to have Output
1020 -- items in its dependency relations. Note that "null"
1021 -- and attribute 'Result are still valid items.
1023 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1024 and then not Is_Input
1027 ("output item is not applicable to function", Item
);
1030 -- The item denotes a concurrent type. Note that single
1031 -- protected/task types are not considered here because
1032 -- they behave as objects in the context of pragma
1033 -- [Refined_]Depends.
1035 if Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
1037 -- This use is legal as long as the concurrent type is
1038 -- the current instance of an enclosing type.
1040 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
1042 -- The dependence of a task unit on itself is
1043 -- implicit and may or may not be explicitly
1044 -- specified (SPARK RM 6.1.4).
1046 if Ekind
(Item_Id
) = E_Task_Type
then
1047 Current_Task_Instance_Seen
;
1050 -- Otherwise this is not the current instance
1054 ("invalid use of subtype mark in dependency "
1055 & "relation", Item
);
1058 -- The dependency of a task unit on itself is implicit
1059 -- and may or may not be explicitly specified
1060 -- (SPARK RM 6.1.4).
1062 elsif Is_Single_Task_Object
(Item_Id
)
1063 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
1065 Current_Task_Instance_Seen
;
1068 -- Ensure that the item fulfills its role as input and/or
1069 -- output as specified by pragma Global or the enclosing
1072 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1074 -- Detect multiple uses of the same state, variable or
1075 -- formal parameter. If this is not the case, add the
1076 -- item to the list of processed relations.
1078 if Contains
(Seen
, Item_Id
) then
1080 ("duplicate use of item &", Item
, Item_Id
);
1082 Append_New_Elmt
(Item_Id
, Seen
);
1085 -- Detect illegal use of an input related to a null
1086 -- output. Such input items cannot appear in other
1087 -- input lists (SPARK RM 6.1.5(13)).
1090 and then Null_Output_Seen
1091 and then Contains
(All_Inputs_Seen
, Item_Id
)
1094 ("input of a null output list cannot appear in "
1095 & "multiple input lists", Item
);
1098 -- Add an input or a self-referential output to the list
1099 -- of all processed inputs.
1101 if Is_Input
or else Self_Ref
then
1102 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1105 -- State related checks (SPARK RM 6.1.5(3))
1107 if Ekind
(Item_Id
) = E_Abstract_State
then
1109 -- Package and subprogram bodies are instantiated
1110 -- individually in a separate compiler pass. Due to
1111 -- this mode of instantiation, the refinement of a
1112 -- state may no longer be visible when a subprogram
1113 -- body contract is instantiated. Since the generic
1114 -- template is legal, do not perform this check in
1115 -- the instance to circumvent this oddity.
1120 -- An abstract state with visible refinement cannot
1121 -- appear in pragma [Refined_]Depends as its place
1122 -- must be taken by some of its constituents
1123 -- (SPARK RM 6.1.4(7)).
1125 elsif Has_Visible_Refinement
(Item_Id
) then
1127 ("cannot mention state & in dependence relation",
1129 SPARK_Msg_N
("\use its constituents instead", Item
);
1132 -- If the reference to the abstract state appears in
1133 -- an enclosing package body that will eventually
1134 -- refine the state, record the reference for future
1138 Record_Possible_Body_Reference
1139 (State_Id
=> Item_Id
,
1143 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
1144 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
1147 ("overlaying object & cannot appear in Depends",
1150 ("\use the overlaid object & instead",
1151 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
1155 -- When the item renames an entire object, replace the
1156 -- item with a reference to the object.
1158 if Entity
(Item
) /= Item_Id
then
1160 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1164 -- Add the entity of the current item to the list of
1167 if Ekind
(Item_Id
) = E_Abstract_State
then
1168 Append_New_Elmt
(Item_Id
, States_Seen
);
1170 -- The variable may eventually become a constituent of a
1171 -- single protected/task type. Record the reference now
1172 -- and verify its legality when analyzing the contract of
1173 -- the variable (SPARK RM 9.3).
1175 elsif Ekind
(Item_Id
) = E_Variable
then
1176 Record_Possible_Part_Of_Reference
1181 if Ekind
(Item_Id
) in E_Abstract_State
1184 and then Present
(Encapsulating_State
(Item_Id
))
1186 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1189 -- All other input/output items are illegal
1190 -- (SPARK RM 6.1.5(1)).
1194 ("item must denote parameter, variable, state or "
1195 & "current instance of concurrent type", Item
);
1198 -- All other input/output items are illegal
1199 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1203 ("item must denote parameter, variable, state or current "
1204 & "instance of concurrent type", Item
);
1207 end Analyze_Input_Output
;
1215 Non_Null_Output_Seen
: Boolean := False;
1216 -- Flag used to check the legality of an output list
1218 -- Start of processing for Analyze_Dependency_Clause
1221 Inputs
:= Expression
(Clause
);
1224 -- An input list with a self-dependency appears as operator "+" where
1225 -- the actuals inputs are the right operand.
1227 if Nkind
(Inputs
) = N_Op_Plus
then
1228 Inputs
:= Right_Opnd
(Inputs
);
1232 -- Process the output_list of a dependency_clause
1234 Output
:= First
(Choices
(Clause
));
1235 while Present
(Output
) loop
1236 Analyze_Input_Output
1239 Self_Ref
=> Self_Ref
,
1241 Seen
=> All_Outputs_Seen
,
1242 Null_Seen
=> Null_Output_Seen
,
1243 Non_Null_Seen
=> Non_Null_Output_Seen
);
1248 -- Process the input_list of a dependency_clause
1250 Analyze_Input_List
(Inputs
);
1251 end Analyze_Dependency_Clause
;
1253 ---------------------------
1254 -- Check_Function_Return --
1255 ---------------------------
1257 procedure Check_Function_Return
is
1259 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1260 and then not Result_Seen
1263 ("result of & must appear in exactly one output list",
1266 end Check_Function_Return
;
1272 procedure Check_Role
1274 Item_Id
: Entity_Id
;
1279 (Item_Is_Input
: out Boolean;
1280 Item_Is_Output
: out Boolean);
1281 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1282 -- Item_Is_Output are set depending on the role.
1284 procedure Role_Error
1285 (Item_Is_Input
: Boolean;
1286 Item_Is_Output
: Boolean);
1287 -- Emit an error message concerning the incorrect use of Item in
1288 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1289 -- denote whether the item is an input and/or an output.
1296 (Item_Is_Input
: out Boolean;
1297 Item_Is_Output
: out Boolean)
1299 -- A constant or an IN parameter of a procedure or a protected
1300 -- entry, if it is of an access-to-variable type, should be
1301 -- handled like a variable, as the underlying memory pointed-to
1302 -- can be modified. Use Adjusted_Kind to do this adjustment.
1304 Adjusted_Kind
: Entity_Kind
:= Ekind
(Item_Id
);
1307 if (Ekind
(Item_Id
) in E_Constant | E_Generic_In_Parameter
1309 (Ekind
(Item_Id
) = E_In_Parameter
1310 and then Ekind
(Scope
(Item_Id
))
1311 not in E_Function | E_Generic_Function
))
1312 and then Is_Access_Variable
(Etype
(Item_Id
))
1313 and then Ekind
(Spec_Id
) not in E_Function
1314 | E_Generic_Function
1316 Adjusted_Kind
:= E_Variable
;
1319 case Adjusted_Kind
is
1323 when E_Abstract_State
=>
1325 -- When pragma Global is present it determines the mode of
1326 -- the abstract state.
1329 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1330 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1332 -- Otherwise the state has a default IN OUT mode, because it
1333 -- behaves as a variable.
1336 Item_Is_Input
:= True;
1337 Item_Is_Output
:= True;
1340 -- Constants and IN parameters
1343 | E_Generic_In_Parameter
1347 -- When pragma Global is present it determines the mode
1348 -- of constant objects as inputs (and such objects cannot
1349 -- appear as outputs in the Global contract).
1352 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1354 Item_Is_Input
:= True;
1357 Item_Is_Output
:= False;
1359 -- Variables and IN OUT parameters, as well as constants and
1360 -- IN parameters of access type which are handled like
1363 when E_Generic_In_Out_Parameter
1364 | E_In_Out_Parameter
1368 -- An OUT parameter of the related subprogram; it cannot
1369 -- appear in Global.
1371 if Adjusted_Kind
= E_Out_Parameter
1372 and then Scope
(Item_Id
) = Spec_Id
1375 -- The parameter has mode IN if its type is unconstrained
1376 -- or tagged because array bounds, discriminants or tags
1380 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1382 Item_Is_Output
:= True;
1384 -- A parameter of an enclosing subprogram; it can appear
1385 -- in Global and behaves as a read-write variable.
1388 -- When pragma Global is present it determines the mode
1393 -- A variable has mode IN when its type is
1394 -- unconstrained or tagged because array bounds,
1395 -- discriminants, or tags can be read.
1398 Appears_In
(Subp_Inputs
, Item_Id
)
1399 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1401 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1403 -- Otherwise the variable has a default IN OUT mode
1406 Item_Is_Input
:= True;
1407 Item_Is_Output
:= True;
1413 when E_Protected_Type
=>
1416 -- A variable has mode IN when its type is unconstrained
1417 -- or tagged because array bounds, discriminants or tags
1421 Appears_In
(Subp_Inputs
, Item_Id
)
1422 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1424 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1427 -- A protected type acts as a formal parameter of mode IN
1428 -- when it applies to a protected function.
1430 if Ekind
(Spec_Id
) = E_Function
then
1431 Item_Is_Input
:= True;
1432 Item_Is_Output
:= False;
1434 -- Otherwise the protected type acts as a formal of mode
1438 Item_Is_Input
:= True;
1439 Item_Is_Output
:= True;
1447 -- When pragma Global is present it determines the mode of
1452 Appears_In
(Subp_Inputs
, Item_Id
)
1453 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1455 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1457 -- Otherwise task types act as IN OUT parameters
1460 Item_Is_Input
:= True;
1461 Item_Is_Output
:= True;
1465 raise Program_Error
;
1473 procedure Role_Error
1474 (Item_Is_Input
: Boolean;
1475 Item_Is_Output
: Boolean)
1480 -- When the item is not part of the input and the output set of
1481 -- the related subprogram, then it appears as extra in pragma
1482 -- [Refined_]Depends.
1484 if not Item_Is_Input
and then not Item_Is_Output
then
1485 Add_Item_To_Name_Buffer
(Item_Id
);
1486 Add_Str_To_Name_Buffer
1487 (" & cannot appear in dependence relation");
1489 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1491 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1493 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1494 & "set of subprogram %"), Item
, Item_Id
);
1496 -- The mode of the item and its role in pragma [Refined_]Depends
1497 -- are in conflict. Construct a detailed message explaining the
1498 -- illegality (SPARK RM 6.1.5(5-6)).
1501 if Item_Is_Input
then
1502 Add_Str_To_Name_Buffer
("read-only");
1504 Add_Str_To_Name_Buffer
("write-only");
1507 Add_Char_To_Name_Buffer
(' ');
1508 Add_Item_To_Name_Buffer
(Item_Id
);
1509 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1511 if Item_Is_Input
then
1512 Add_Str_To_Name_Buffer
("output");
1514 Add_Str_To_Name_Buffer
("input");
1517 Add_Str_To_Name_Buffer
(" in dependence relation");
1519 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1525 Item_Is_Input
: Boolean;
1526 Item_Is_Output
: Boolean;
1528 -- Start of processing for Check_Role
1531 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1536 if not Item_Is_Input
then
1537 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1540 -- Self-referential item
1543 if not Item_Is_Input
or else not Item_Is_Output
then
1544 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1549 elsif not Item_Is_Output
then
1550 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1558 procedure Check_Usage
1559 (Subp_Items
: Elist_Id
;
1560 Used_Items
: Elist_Id
;
1563 procedure Usage_Error
(Item_Id
: Entity_Id
);
1564 -- Emit an error concerning the illegal usage of an item
1570 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1576 -- Unconstrained and tagged items are not part of the explicit
1577 -- input set of the related subprogram, they do not have to be
1578 -- present in a dependence relation and should not be flagged
1579 -- (SPARK RM 6.1.5(5)).
1581 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1584 Add_Item_To_Name_Buffer
(Item_Id
);
1585 Add_Str_To_Name_Buffer
1586 (" & is missing from input dependence list");
1588 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1590 ("\add `null ='> &` dependency to ignore this input",
1594 -- Output case (SPARK RM 6.1.5(10))
1599 Add_Item_To_Name_Buffer
(Item_Id
);
1600 Add_Str_To_Name_Buffer
1601 (" & is missing from output dependence list");
1603 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1611 Item_Id
: Entity_Id
;
1613 -- Start of processing for Check_Usage
1616 if No
(Subp_Items
) then
1620 -- Each input or output of the subprogram must appear in a dependency
1623 Elmt
:= First_Elmt
(Subp_Items
);
1624 while Present
(Elmt
) loop
1625 Item
:= Node
(Elmt
);
1627 if Nkind
(Item
) = N_Defining_Identifier
then
1630 Item_Id
:= Entity_Of
(Item
);
1633 -- The item does not appear in a dependency
1635 if Present
(Item_Id
)
1636 and then not Contains
(Used_Items
, Item_Id
)
1638 if Is_Formal
(Item_Id
) then
1639 Usage_Error
(Item_Id
);
1641 -- The current instance of a protected type behaves as a formal
1642 -- parameter (SPARK RM 6.1.4).
1644 elsif Ekind
(Item_Id
) = E_Protected_Type
1645 or else Is_Single_Protected_Object
(Item_Id
)
1647 Usage_Error
(Item_Id
);
1649 -- The current instance of a task type behaves as a formal
1650 -- parameter (SPARK RM 6.1.4).
1652 elsif Ekind
(Item_Id
) = E_Task_Type
1653 or else Is_Single_Task_Object
(Item_Id
)
1655 -- The dependence of a task unit on itself is implicit and
1656 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1657 -- Emit an error if only one input/output is present.
1659 if Task_Input_Seen
/= Task_Output_Seen
then
1660 Usage_Error
(Item_Id
);
1663 -- States and global objects are not used properly only when
1664 -- the subprogram is subject to pragma Global.
1667 and then Ekind
(Item_Id
) in E_Abstract_State
1675 Usage_Error
(Item_Id
);
1683 ----------------------
1684 -- Normalize_Clause --
1685 ----------------------
1687 procedure Normalize_Clause
(Clause
: Node_Id
) is
1688 procedure Create_Or_Modify_Clause
1694 Multiple
: Boolean);
1695 -- Create a brand new clause to represent the self-reference or
1696 -- modify the input and/or output lists of an existing clause. Output
1697 -- denotes a self-referencial output. Outputs is the output list of a
1698 -- clause. Inputs is the input list of a clause. After denotes the
1699 -- clause after which the new clause is to be inserted. Flag In_Place
1700 -- should be set when normalizing the last output of an output list.
1701 -- Flag Multiple should be set when Output comes from a list with
1704 -----------------------------
1705 -- Create_Or_Modify_Clause --
1706 -----------------------------
1708 procedure Create_Or_Modify_Clause
1716 procedure Propagate_Output
1719 -- Handle the various cases of output propagation to the input
1720 -- list. Output denotes a self-referencial output item. Inputs
1721 -- is the input list of a clause.
1723 ----------------------
1724 -- Propagate_Output --
1725 ----------------------
1727 procedure Propagate_Output
1731 function In_Input_List
1733 Inputs
: List_Id
) return Boolean;
1734 -- Determine whether a particulat item appears in the input
1735 -- list of a clause.
1741 function In_Input_List
1743 Inputs
: List_Id
) return Boolean
1748 Elmt
:= First
(Inputs
);
1749 while Present
(Elmt
) loop
1750 if Entity_Of
(Elmt
) = Item
then
1762 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1765 -- Start of processing for Propagate_Output
1768 -- The clause is of the form:
1770 -- (Output =>+ null)
1772 -- Remove null input and replace it with a copy of the output:
1774 -- (Output => Output)
1776 if Nkind
(Inputs
) = N_Null
then
1777 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1779 -- The clause is of the form:
1781 -- (Output =>+ (Input1, ..., InputN))
1783 -- Determine whether the output is not already mentioned in the
1784 -- input list and if not, add it to the list of inputs:
1786 -- (Output => (Output, Input1, ..., InputN))
1788 elsif Nkind
(Inputs
) = N_Aggregate
then
1789 Grouped
:= Expressions
(Inputs
);
1791 if not In_Input_List
1795 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1798 -- The clause is of the form:
1800 -- (Output =>+ Input)
1802 -- If the input does not mention the output, group the two
1805 -- (Output => (Output, Input))
1807 elsif Entity_Of
(Inputs
) /= Output_Id
then
1809 Make_Aggregate
(Loc
,
1810 Expressions
=> New_List
(
1811 New_Copy_Tree
(Output
),
1812 New_Copy_Tree
(Inputs
))));
1814 end Propagate_Output
;
1818 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1819 New_Clause
: Node_Id
;
1821 -- Start of processing for Create_Or_Modify_Clause
1824 -- A null output depending on itself does not require any
1827 if Nkind
(Output
) = N_Null
then
1830 -- A function result cannot depend on itself because it cannot
1831 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1833 elsif Is_Attribute_Result
(Output
) then
1834 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1838 -- When performing the transformation in place, simply add the
1839 -- output to the list of inputs (if not already there). This
1840 -- case arises when dealing with the last output of an output
1841 -- list. Perform the normalization in place to avoid generating
1842 -- a malformed tree.
1845 Propagate_Output
(Output
, Inputs
);
1847 -- A list with multiple outputs is slowly trimmed until only
1848 -- one element remains. When this happens, replace aggregate
1849 -- with the element itself.
1853 Rewrite
(Outputs
, Output
);
1859 -- Unchain the output from its output list as it will appear in
1860 -- a new clause. Note that we cannot simply rewrite the output
1861 -- as null because this will violate the semantics of pragma
1866 -- Generate a new clause of the form:
1867 -- (Output => Inputs)
1870 Make_Component_Association
(Loc
,
1871 Choices
=> New_List
(Output
),
1872 Expression
=> New_Copy_Tree
(Inputs
));
1874 -- The new clause contains replicated content that has already
1875 -- been analyzed. There is not need to reanalyze or renormalize
1878 Set_Analyzed
(New_Clause
);
1881 (Output
=> First
(Choices
(New_Clause
)),
1882 Inputs
=> Expression
(New_Clause
));
1884 Insert_After
(After
, New_Clause
);
1886 end Create_Or_Modify_Clause
;
1890 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1892 Last_Output
: Node_Id
;
1893 Next_Output
: Node_Id
;
1896 -- Start of processing for Normalize_Clause
1899 -- A self-dependency appears as operator "+". Remove the "+" from the
1900 -- tree by moving the real inputs to their proper place.
1902 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1903 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1904 Inputs
:= Expression
(Clause
);
1906 -- Multiple outputs appear as an aggregate
1908 if Nkind
(Outputs
) = N_Aggregate
then
1909 Last_Output
:= Last
(Expressions
(Outputs
));
1911 Output
:= First
(Expressions
(Outputs
));
1912 while Present
(Output
) loop
1914 -- Normalization may remove an output from its list,
1915 -- preserve the subsequent output now.
1917 Next_Output
:= Next
(Output
);
1919 Create_Or_Modify_Clause
1924 In_Place
=> Output
= Last_Output
,
1927 Output
:= Next_Output
;
1933 Create_Or_Modify_Clause
1942 end Normalize_Clause
;
1946 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1947 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1951 Last_Clause
: Node_Id
;
1952 Restore_Scope
: Boolean := False;
1954 -- Start of processing for Analyze_Depends_In_Decl_Part
1957 -- Do not analyze the pragma multiple times
1959 if Is_Analyzed_Pragma
(N
) then
1963 -- Empty dependency list
1965 if Nkind
(Deps
) = N_Null
then
1967 -- Gather all states, objects and formal parameters that the
1968 -- subprogram may depend on. These items are obtained from the
1969 -- parameter profile or pragma [Refined_]Global (if available).
1971 Collect_Subprogram_Inputs_Outputs
1972 (Subp_Id
=> Subp_Id
,
1973 Subp_Inputs
=> Subp_Inputs
,
1974 Subp_Outputs
=> Subp_Outputs
,
1975 Global_Seen
=> Global_Seen
);
1977 -- Verify that every input or output of the subprogram appear in a
1980 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1981 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1982 Check_Function_Return
;
1984 -- Dependency clauses appear as component associations of an aggregate
1986 elsif Nkind
(Deps
) = N_Aggregate
then
1988 -- Do not attempt to perform analysis of a syntactically illegal
1989 -- clause as this will lead to misleading errors.
1991 if Has_Extra_Parentheses
(Deps
) then
1995 if Present
(Component_Associations
(Deps
)) then
1996 Last_Clause
:= Last
(Component_Associations
(Deps
));
1998 -- Gather all states, objects and formal parameters that the
1999 -- subprogram may depend on. These items are obtained from the
2000 -- parameter profile or pragma [Refined_]Global (if available).
2002 Collect_Subprogram_Inputs_Outputs
2003 (Subp_Id
=> Subp_Id
,
2004 Subp_Inputs
=> Subp_Inputs
,
2005 Subp_Outputs
=> Subp_Outputs
,
2006 Global_Seen
=> Global_Seen
);
2008 -- When pragma [Refined_]Depends appears on a single concurrent
2009 -- type, it is relocated to the anonymous object.
2011 if Is_Single_Concurrent_Object
(Spec_Id
) then
2014 -- Ensure that the formal parameters are visible when analyzing
2015 -- all clauses. This falls out of the general rule of aspects
2016 -- pertaining to subprogram declarations.
2018 elsif not In_Open_Scopes
(Spec_Id
) then
2019 Restore_Scope
:= True;
2020 Push_Scope
(Spec_Id
);
2022 if Ekind
(Spec_Id
) = E_Task_Type
then
2024 -- Task discriminants cannot appear in the [Refined_]Depends
2025 -- contract, but must be present for the analysis so that we
2026 -- can reject them with an informative error message.
2028 if Has_Discriminants
(Spec_Id
) then
2029 Install_Discriminants
(Spec_Id
);
2032 elsif Is_Generic_Subprogram
(Spec_Id
) then
2033 Install_Generic_Formals
(Spec_Id
);
2036 Install_Formals
(Spec_Id
);
2040 Clause
:= First
(Component_Associations
(Deps
));
2041 while Present
(Clause
) loop
2042 Errors
:= Serious_Errors_Detected
;
2044 -- The normalization mechanism may create extra clauses that
2045 -- contain replicated input and output names. There is no need
2046 -- to reanalyze them.
2048 if not Analyzed
(Clause
) then
2049 Set_Analyzed
(Clause
);
2051 Analyze_Dependency_Clause
2053 Is_Last
=> Clause
= Last_Clause
);
2056 -- Do not normalize a clause if errors were detected (count
2057 -- of Serious_Errors has increased) because the inputs and/or
2058 -- outputs may denote illegal items.
2060 if Serious_Errors_Detected
= Errors
then
2061 Normalize_Clause
(Clause
);
2067 if Restore_Scope
then
2071 -- Verify that every input or output of the subprogram appear in a
2074 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
2075 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
2076 Check_Function_Return
;
2078 -- The dependency list is malformed. This is a syntax error, always
2082 Error_Msg_N
("malformed dependency relation", Deps
);
2086 -- The top level dependency relation is malformed. This is a syntax
2087 -- error, always report.
2090 Error_Msg_N
("malformed dependency relation", Deps
);
2094 -- Ensure that a state and a corresponding constituent do not appear
2095 -- together in pragma [Refined_]Depends.
2097 Check_State_And_Constituent_Use
2098 (States
=> States_Seen
,
2099 Constits
=> Constits_Seen
,
2103 Set_Is_Analyzed_Pragma
(N
);
2104 end Analyze_Depends_In_Decl_Part
;
2106 --------------------------------------------
2107 -- Analyze_External_Property_In_Decl_Part --
2108 --------------------------------------------
2110 procedure Analyze_External_Property_In_Decl_Part
2112 Expr_Val
: out Boolean)
2114 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pragma_Name
(N
));
2115 Arg1
: constant Node_Id
:=
2116 First
(Pragma_Argument_Associations
(N
));
2117 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2118 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2119 Obj_Typ
: Entity_Id
;
2123 if Is_Type
(Obj_Id
) then
2126 Obj_Typ
:= Etype
(Obj_Id
);
2129 -- Ensure that the Boolean expression (if present) is static. A missing
2130 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2134 if Present
(Arg1
) then
2135 Expr
:= Get_Pragma_Arg
(Arg1
);
2137 if Is_OK_Static_Expression
(Expr
) then
2138 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2142 -- The output parameter was set to the argument specified by the pragma.
2143 -- Do not analyze the pragma multiple times.
2145 if Is_Analyzed_Pragma
(N
) then
2149 Error_Msg_Name_1
:= Pragma_Name
(N
);
2151 -- An external property pragma must apply to an effectively volatile
2152 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2153 -- The check is performed at the end of the declarative region due to a
2154 -- possible out-of-order arrangement of pragmas:
2157 -- pragma Async_Readers (Obj);
2158 -- pragma Volatile (Obj);
2160 if Prag_Id
/= Pragma_No_Caching
2161 and then not Is_Effectively_Volatile
(Obj_Id
)
2163 if No_Caching_Enabled
(Obj_Id
) then
2164 if Expr_Val
then -- Confirming value of False is allowed
2166 ("illegal combination of external property % and property "
2167 & """No_Caching"" (SPARK RM 7.1.2(6))", N
);
2171 ("external property % must apply to a volatile type or object",
2175 -- Pragma No_Caching should only apply to volatile types or variables of
2176 -- a non-effectively volatile type (SPARK RM 7.1.2).
2178 elsif Prag_Id
= Pragma_No_Caching
then
2179 if Is_Effectively_Volatile
(Obj_Typ
) then
2180 SPARK_Msg_N
("property % must not apply to a type or object of "
2181 & "an effectively volatile type", N
);
2182 elsif not Is_Volatile
(Obj_Id
) then
2184 ("property % must apply to a volatile type or object", N
);
2188 Set_Is_Analyzed_Pragma
(N
);
2189 end Analyze_External_Property_In_Decl_Part
;
2191 ---------------------------------
2192 -- Analyze_Global_In_Decl_Part --
2193 ---------------------------------
2195 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2196 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2197 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2198 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2200 Constits_Seen
: Elist_Id
:= No_Elist
;
2201 -- A list containing the entities of all constituents processed so far.
2202 -- It aids in detecting illegal usage of a state and a corresponding
2203 -- constituent in pragma [Refinde_]Global.
2205 Seen
: Elist_Id
:= No_Elist
;
2206 -- A list containing the entities of all the items processed so far. It
2207 -- plays a role in detecting distinct entities.
2209 States_Seen
: Elist_Id
:= No_Elist
;
2210 -- A list containing the entities of all states processed so far. It
2211 -- helps in detecting illegal usage of a state and a corresponding
2212 -- constituent in pragma [Refined_]Global.
2214 In_Out_Seen
: Boolean := False;
2215 Input_Seen
: Boolean := False;
2216 Output_Seen
: Boolean := False;
2217 Proof_Seen
: Boolean := False;
2218 -- Flags used to verify the consistency of modes
2220 procedure Analyze_Global_List
2222 Global_Mode
: Name_Id
:= Name_Input
);
2223 -- Verify the legality of a single global list declaration. Global_Mode
2224 -- denotes the current mode in effect.
2226 -------------------------
2227 -- Analyze_Global_List --
2228 -------------------------
2230 procedure Analyze_Global_List
2232 Global_Mode
: Name_Id
:= Name_Input
)
2234 procedure Analyze_Global_Item
2236 Global_Mode
: Name_Id
);
2237 -- Verify the legality of a single global item declaration denoted by
2238 -- Item. Global_Mode denotes the current mode in effect.
2240 procedure Check_Duplicate_Mode
2242 Status
: in out Boolean);
2243 -- Flag Status denotes whether a particular mode has been seen while
2244 -- processing a global list. This routine verifies that Mode is not a
2245 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2247 procedure Check_Mode_Restriction_In_Enclosing_Context
2249 Item_Id
: Entity_Id
);
2250 -- Verify that an item of mode In_Out or Output does not appear as
2251 -- an input in the Global aspect of an enclosing subprogram or task
2252 -- unit. If this is the case, emit an error. Item and Item_Id are
2253 -- respectively the item and its entity.
2255 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2256 -- Mode denotes either In_Out or Output. Depending on the kind of the
2257 -- related subprogram, emit an error if those two modes apply to a
2258 -- function (SPARK RM 6.1.4(10)).
2260 -------------------------
2261 -- Analyze_Global_Item --
2262 -------------------------
2264 procedure Analyze_Global_Item
2266 Global_Mode
: Name_Id
)
2268 Item_Id
: Entity_Id
;
2271 -- Detect one of the following cases
2273 -- with Global => (null, Name)
2274 -- with Global => (Name_1, null, Name_2)
2275 -- with Global => (Name, null)
2277 if Nkind
(Item
) = N_Null
then
2278 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2283 Resolve_State
(Item
);
2285 -- Find the entity of the item. If this is a renaming, climb the
2286 -- renaming chain to reach the root object. Renamings of non-
2287 -- entire objects do not yield an entity (Empty).
2289 Item_Id
:= Entity_Of
(Item
);
2291 if Present
(Item_Id
) then
2293 -- A global item may denote a formal parameter of an enclosing
2294 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2295 -- provide a better error diagnostic.
2297 if Is_Formal
(Item_Id
) then
2298 if Scope
(Item_Id
) = Spec_Id
then
2300 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2301 & "parameter of subprogram &"), Item
, Spec_Id
);
2305 -- A global item may denote a concurrent type as long as it is
2306 -- the current instance of an enclosing protected or task type
2307 -- (SPARK RM 6.1.4).
2309 elsif Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
2310 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2312 -- Pragma [Refined_]Global associated with a protected
2313 -- subprogram cannot mention the current instance of a
2314 -- protected type because the instance behaves as a
2315 -- formal parameter.
2317 if Ekind
(Item_Id
) = E_Protected_Type
then
2318 if Scope
(Spec_Id
) = Item_Id
then
2319 Error_Msg_Name_1
:= Chars
(Item_Id
);
2321 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2322 & "cannot reference current instance of "
2323 & "protected type %"), Item
, Spec_Id
);
2327 -- Pragma [Refined_]Global associated with a task type
2328 -- cannot mention the current instance of a task type
2329 -- because the instance behaves as a formal parameter.
2331 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2332 if Spec_Id
= Item_Id
then
2333 Error_Msg_Name_1
:= Chars
(Item_Id
);
2335 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2336 & "cannot reference current instance of task "
2337 & "type %"), Item
, Spec_Id
);
2342 -- Otherwise the global item denotes a subtype mark that is
2343 -- not a current instance.
2347 ("invalid use of subtype mark in global list", Item
);
2351 -- A global item may denote the anonymous object created for a
2352 -- single protected/task type as long as the current instance
2353 -- is the same single type (SPARK RM 6.1.4).
2355 elsif Is_Single_Concurrent_Object
(Item_Id
)
2356 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2358 -- Pragma [Refined_]Global associated with a protected
2359 -- subprogram cannot mention the current instance of a
2360 -- protected type because the instance behaves as a formal
2363 if Is_Single_Protected_Object
(Item_Id
) then
2364 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2365 Error_Msg_Name_1
:= Chars
(Item_Id
);
2367 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2368 & "cannot reference current instance of protected "
2369 & "type %"), Item
, Spec_Id
);
2373 -- Pragma [Refined_]Global associated with a task type
2374 -- cannot mention the current instance of a task type
2375 -- because the instance behaves as a formal parameter.
2377 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2378 if Spec_Id
= Item_Id
then
2379 Error_Msg_Name_1
:= Chars
(Item_Id
);
2381 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2382 & "cannot reference current instance of task "
2383 & "type %"), Item
, Spec_Id
);
2388 -- A formal object may act as a global item inside a generic
2390 elsif Is_Formal_Object
(Item_Id
) then
2393 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
2394 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
2397 ("overlaying object & cannot appear in Global",
2400 ("\use the overlaid object & instead",
2401 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
2404 -- The only legal references are those to abstract states,
2405 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2407 elsif Ekind
(Item_Id
) not in E_Abstract_State
2413 ("global item must denote object, state or current "
2414 & "instance of concurrent type", Item
);
2416 if Is_Named_Number
(Item_Id
) then
2418 ("\named number & is not an object", Item
, Item_Id
);
2424 -- State related checks
2426 if Ekind
(Item_Id
) = E_Abstract_State
then
2428 -- Package and subprogram bodies are instantiated
2429 -- individually in a separate compiler pass. Due to this
2430 -- mode of instantiation, the refinement of a state may
2431 -- no longer be visible when a subprogram body contract
2432 -- is instantiated. Since the generic template is legal,
2433 -- do not perform this check in the instance to circumvent
2439 -- An abstract state with visible refinement cannot appear
2440 -- in pragma [Refined_]Global as its place must be taken by
2441 -- some of its constituents (SPARK RM 6.1.4(7)).
2443 elsif Has_Visible_Refinement
(Item_Id
) then
2445 ("cannot mention state & in global refinement",
2447 SPARK_Msg_N
("\use its constituents instead", Item
);
2450 -- An external state which has Async_Writers or
2451 -- Effective_Reads enabled cannot appear as a global item
2452 -- of a nonvolatile function (SPARK RM 7.1.3(8)).
2454 elsif Is_External_State
(Item_Id
)
2455 and then (Async_Writers_Enabled
(Item_Id
)
2456 or else Effective_Reads_Enabled
(Item_Id
))
2457 and then Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2458 and then not Is_Volatile_Function
(Spec_Id
)
2461 ("external state & cannot act as global item of "
2462 & "nonvolatile function", Item
, Item_Id
);
2465 -- If the reference to the abstract state appears in an
2466 -- enclosing package body that will eventually refine the
2467 -- state, record the reference for future checks.
2470 Record_Possible_Body_Reference
2471 (State_Id
=> Item_Id
,
2475 -- Constant related checks
2477 elsif Ekind
(Item_Id
) = E_Constant
then
2479 -- Constant is a read-only item, therefore it cannot act as
2482 if Global_Mode
in Name_In_Out | Name_Output
then
2484 -- Constant of an access-to-variable type is a read-write
2485 -- item in procedures, generic procedures, protected
2486 -- entries and tasks.
2488 if Is_Access_Variable
(Etype
(Item_Id
))
2489 and then (Ekind
(Spec_Id
) in E_Entry
2492 | E_Generic_Procedure
2494 or else Is_Single_Task_Object
(Spec_Id
))
2499 ("constant & cannot act as output", Item
, Item_Id
);
2504 -- Loop parameter related checks
2506 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2508 -- A loop parameter is a read-only item, therefore it cannot
2509 -- act as an output.
2511 if Global_Mode
in Name_In_Out | Name_Output
then
2513 ("loop parameter & cannot act as output",
2518 -- Variable related checks. These are only relevant when
2519 -- SPARK_Mode is on as they are not standard Ada legality
2522 elsif SPARK_Mode
= On
2523 and then Ekind
(Item_Id
) = E_Variable
2524 and then Is_Effectively_Volatile_For_Reading
(Item_Id
)
2526 -- The current instance of a protected unit is not an
2527 -- effectively volatile object, unless the protected unit
2528 -- is already volatile for another reason (SPARK RM 7.1.2).
2530 if Is_Single_Protected_Object
(Item_Id
)
2531 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2532 and then not Is_Effectively_Volatile_For_Reading
2533 (Item_Id
, Ignore_Protected
=> True)
2537 -- An effectively volatile object for reading cannot appear
2538 -- as a global item of a nonvolatile function (SPARK RM
2541 elsif Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2542 and then not Is_Volatile_Function
(Spec_Id
)
2545 ("volatile object & cannot act as global item of a "
2546 & "function", Item
, Item_Id
);
2549 -- An effectively volatile object with external property
2550 -- Effective_Reads set to True must have mode Output or
2551 -- In_Out (SPARK RM 7.1.3(10)).
2553 elsif Effective_Reads_Enabled
(Item_Id
)
2554 and then Global_Mode
= Name_Input
2557 ("volatile object & with property Effective_Reads must "
2558 & "have mode In_Out or Output", Item
, Item_Id
);
2563 -- When the item renames an entire object, replace the item
2564 -- with a reference to the object.
2566 if Entity
(Item
) /= Item_Id
then
2567 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2571 -- Some form of illegal construct masquerading as a name
2572 -- (SPARK RM 6.1.4(4)).
2576 ("global item must denote object, state or current instance "
2577 & "of concurrent type", Item
);
2581 -- Verify that an output does not appear as an input in an
2582 -- enclosing subprogram.
2584 if Global_Mode
in Name_In_Out | Name_Output
then
2585 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2588 -- The same entity might be referenced through various way.
2589 -- Check the entity of the item rather than the item itself
2590 -- (SPARK RM 6.1.4(10)).
2592 if Contains
(Seen
, Item_Id
) then
2593 SPARK_Msg_N
("duplicate global item", Item
);
2595 -- Add the entity of the current item to the list of processed
2599 Append_New_Elmt
(Item_Id
, Seen
);
2601 if Ekind
(Item_Id
) = E_Abstract_State
then
2602 Append_New_Elmt
(Item_Id
, States_Seen
);
2604 -- The variable may eventually become a constituent of a single
2605 -- protected/task type. Record the reference now and verify its
2606 -- legality when analyzing the contract of the variable
2609 elsif Ekind
(Item_Id
) = E_Variable
then
2610 Record_Possible_Part_Of_Reference
2615 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
2616 and then Present
(Encapsulating_State
(Item_Id
))
2618 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2621 end Analyze_Global_Item
;
2623 --------------------------
2624 -- Check_Duplicate_Mode --
2625 --------------------------
2627 procedure Check_Duplicate_Mode
2629 Status
: in out Boolean)
2633 SPARK_Msg_N
("duplicate global mode", Mode
);
2637 end Check_Duplicate_Mode
;
2639 -------------------------------------------------
2640 -- Check_Mode_Restriction_In_Enclosing_Context --
2641 -------------------------------------------------
2643 procedure Check_Mode_Restriction_In_Enclosing_Context
2645 Item_Id
: Entity_Id
)
2647 Context
: Entity_Id
;
2649 Inputs
: Elist_Id
:= No_Elist
;
2650 Outputs
: Elist_Id
:= No_Elist
;
2653 -- Traverse the scope stack looking for enclosing subprograms or
2654 -- tasks subject to pragma [Refined_]Global.
2656 Context
:= Scope
(Subp_Id
);
2657 while Present
(Context
) and then Context
/= Standard_Standard
loop
2659 -- For a single task type, retrieve the corresponding object to
2660 -- which pragma [Refined_]Global is attached.
2662 if Ekind
(Context
) = E_Task_Type
2663 and then Is_Single_Concurrent_Type
(Context
)
2665 Context
:= Anonymous_Object
(Context
);
2668 if Is_Subprogram_Or_Entry
(Context
)
2669 or else Ekind
(Context
) = E_Task_Type
2670 or else Is_Single_Task_Object
(Context
)
2672 Collect_Subprogram_Inputs_Outputs
2673 (Subp_Id
=> Context
,
2674 Subp_Inputs
=> Inputs
,
2675 Subp_Outputs
=> Outputs
,
2676 Global_Seen
=> Dummy
);
2678 -- The item is classified as In_Out or Output but appears as
2679 -- an Input or a formal parameter of mode IN in an enclosing
2680 -- subprogram or task unit (SPARK RM 6.1.4(13)).
2682 if Appears_In
(Inputs
, Item_Id
)
2683 and then not Appears_In
(Outputs
, Item_Id
)
2686 ("global item & cannot have mode In_Out or Output",
2689 if Is_Subprogram_Or_Entry
(Context
) then
2691 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2692 & "of subprogram &"), Item
, Context
);
2695 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2696 & "of task &"), Item
, Context
);
2699 -- Stop the traversal once an error has been detected
2705 Context
:= Scope
(Context
);
2707 end Check_Mode_Restriction_In_Enclosing_Context
;
2709 ----------------------------------------
2710 -- Check_Mode_Restriction_In_Function --
2711 ----------------------------------------
2713 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2715 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
then
2717 ("global mode & is not applicable to functions", Mode
);
2719 end Check_Mode_Restriction_In_Function
;
2727 -- Start of processing for Analyze_Global_List
2730 if Nkind
(List
) = N_Null
then
2731 Set_Analyzed
(List
);
2733 -- Single global item declaration
2735 elsif Nkind
(List
) in N_Expanded_Name
2737 | N_Selected_Component
2739 Analyze_Global_Item
(List
, Global_Mode
);
2741 -- Simple global list or moded global list declaration
2743 elsif Nkind
(List
) = N_Aggregate
then
2744 Set_Analyzed
(List
);
2746 -- The declaration of a simple global list appear as a collection
2749 if Present
(Expressions
(List
)) then
2750 if Present
(Component_Associations
(List
)) then
2752 ("cannot mix moded and non-moded global lists", List
);
2755 Item
:= First
(Expressions
(List
));
2756 while Present
(Item
) loop
2757 Analyze_Global_Item
(Item
, Global_Mode
);
2761 -- The declaration of a moded global list appears as a collection
2762 -- of component associations where individual choices denote
2765 elsif Present
(Component_Associations
(List
)) then
2766 if Present
(Expressions
(List
)) then
2768 ("cannot mix moded and non-moded global lists", List
);
2771 Assoc
:= First
(Component_Associations
(List
));
2772 while Present
(Assoc
) loop
2773 Mode
:= First
(Choices
(Assoc
));
2775 if Nkind
(Mode
) = N_Identifier
then
2776 if Chars
(Mode
) = Name_In_Out
then
2777 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2778 Check_Mode_Restriction_In_Function
(Mode
);
2780 elsif Chars
(Mode
) = Name_Input
then
2781 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2783 elsif Chars
(Mode
) = Name_Output
then
2784 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2785 Check_Mode_Restriction_In_Function
(Mode
);
2787 elsif Chars
(Mode
) = Name_Proof_In
then
2788 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2791 SPARK_Msg_N
("invalid mode selector", Mode
);
2795 SPARK_Msg_N
("invalid mode selector", Mode
);
2798 -- Items in a moded list appear as a collection of
2799 -- expressions. Reuse the existing machinery to analyze
2803 (List
=> Expression
(Assoc
),
2804 Global_Mode
=> Chars
(Mode
));
2812 raise Program_Error
;
2815 -- Any other attempt to declare a global item is illegal. This is a
2816 -- syntax error, always report.
2819 Error_Msg_N
("malformed global list", List
);
2821 end Analyze_Global_List
;
2825 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2827 Restore_Scope
: Boolean := False;
2829 -- Start of processing for Analyze_Global_In_Decl_Part
2832 -- Do not analyze the pragma multiple times
2834 if Is_Analyzed_Pragma
(N
) then
2838 -- There is nothing to be done for a null global list
2840 if Nkind
(Items
) = N_Null
then
2841 Set_Analyzed
(Items
);
2843 -- Analyze the various forms of global lists and items. Note that some
2844 -- of these may be malformed in which case the analysis emits error
2848 -- When pragma [Refined_]Global appears on a single concurrent type,
2849 -- it is relocated to the anonymous object.
2851 if Is_Single_Concurrent_Object
(Spec_Id
) then
2854 -- Ensure that the formal parameters are visible when processing an
2855 -- item. This falls out of the general rule of aspects pertaining to
2856 -- subprogram declarations.
2858 elsif not In_Open_Scopes
(Spec_Id
) then
2859 Restore_Scope
:= True;
2860 Push_Scope
(Spec_Id
);
2862 if Ekind
(Spec_Id
) = E_Task_Type
then
2864 -- Task discriminants cannot appear in the [Refined_]Global
2865 -- contract, but must be present for the analysis so that we
2866 -- can reject them with an informative error message.
2868 if Has_Discriminants
(Spec_Id
) then
2869 Install_Discriminants
(Spec_Id
);
2872 elsif Is_Generic_Subprogram
(Spec_Id
) then
2873 Install_Generic_Formals
(Spec_Id
);
2876 Install_Formals
(Spec_Id
);
2880 Analyze_Global_List
(Items
);
2882 if Restore_Scope
then
2887 -- Ensure that a state and a corresponding constituent do not appear
2888 -- together in pragma [Refined_]Global.
2890 Check_State_And_Constituent_Use
2891 (States
=> States_Seen
,
2892 Constits
=> Constits_Seen
,
2895 Set_Is_Analyzed_Pragma
(N
);
2896 end Analyze_Global_In_Decl_Part
;
2898 --------------------------------------------
2899 -- Analyze_Initial_Condition_In_Decl_Part --
2900 --------------------------------------------
2902 -- WARNING: This routine manages Ghost regions. Return statements must be
2903 -- replaced by gotos which jump to the end of the routine and restore the
2906 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2907 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2908 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2909 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2911 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2912 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2913 -- Save the Ghost-related attributes to restore on exit
2916 -- Do not analyze the pragma multiple times
2918 if Is_Analyzed_Pragma
(N
) then
2922 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2923 -- analysis of the pragma, the Ghost mode at point of declaration and
2924 -- point of analysis may not necessarily be the same. Use the mode in
2925 -- effect at the point of declaration.
2929 -- The expression is preanalyzed because it has not been moved to its
2930 -- final place yet. A direct analysis may generate side effects and this
2931 -- is not desired at this point.
2933 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2934 Set_Is_Analyzed_Pragma
(N
);
2936 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2937 end Analyze_Initial_Condition_In_Decl_Part
;
2939 --------------------------------------
2940 -- Analyze_Initializes_In_Decl_Part --
2941 --------------------------------------
2943 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2944 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2945 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2947 Constits_Seen
: Elist_Id
:= No_Elist
;
2948 -- A list containing the entities of all constituents processed so far.
2949 -- It aids in detecting illegal usage of a state and a corresponding
2950 -- constituent in pragma Initializes.
2952 Items_Seen
: Elist_Id
:= No_Elist
;
2953 -- A list of all initialization items processed so far. This list is
2954 -- used to detect duplicate items.
2956 States_And_Objs
: Elist_Id
:= No_Elist
;
2957 -- A list of all abstract states and objects declared in the visible
2958 -- declarations of the related package. This list is used to detect the
2959 -- legality of initialization items.
2961 States_Seen
: Elist_Id
:= No_Elist
;
2962 -- A list containing the entities of all states processed so far. It
2963 -- helps in detecting illegal usage of a state and a corresponding
2964 -- constituent in pragma Initializes.
2966 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2967 -- Verify the legality of a single initialization item
2969 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2970 -- Verify the legality of a single initialization item followed by a
2971 -- list of input items.
2973 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
);
2974 -- Inspect the visible declarations of the related package and gather
2975 -- the entities of all abstract states and objects in States_And_Objs.
2977 ---------------------------------
2978 -- Analyze_Initialization_Item --
2979 ---------------------------------
2981 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2982 Item_Id
: Entity_Id
;
2986 Resolve_State
(Item
);
2988 if Is_Entity_Name
(Item
) then
2989 Item_Id
:= Entity_Of
(Item
);
2991 if Present
(Item_Id
)
2992 and then Ekind
(Item_Id
) in
2993 E_Abstract_State | E_Constant | E_Variable
2995 -- When the initialization item is undefined, it appears as
2996 -- Any_Id. Do not continue with the analysis of the item.
2998 if Item_Id
= Any_Id
then
3001 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
3002 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
3005 ("overlaying object & cannot appear in Initializes",
3008 ("\use the overlaid object & instead",
3009 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
3011 -- The state or variable must be declared in the visible
3012 -- declarations of the package (SPARK RM 7.1.5(7)).
3014 elsif not Contains
(States_And_Objs
, Item_Id
) then
3015 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3017 ("initialization item & must appear in the visible "
3018 & "declarations of package %", Item
, Item_Id
);
3020 -- Detect a duplicate use of the same initialization item
3021 -- (SPARK RM 7.1.5(5)).
3023 elsif Contains
(Items_Seen
, Item_Id
) then
3024 SPARK_Msg_N
("duplicate initialization item", Item
);
3026 -- The item is legal, add it to the list of processed states
3030 Append_New_Elmt
(Item_Id
, Items_Seen
);
3032 if Ekind
(Item_Id
) = E_Abstract_State
then
3033 Append_New_Elmt
(Item_Id
, States_Seen
);
3036 if Present
(Encapsulating_State
(Item_Id
)) then
3037 Append_New_Elmt
(Item_Id
, Constits_Seen
);
3041 -- The item references something that is not a state or object
3042 -- (SPARK RM 7.1.5(3)).
3046 ("initialization item must denote object or state", Item
);
3049 -- Some form of illegal construct masquerading as a name
3050 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3054 ("initialization item must denote object or state", Item
);
3056 end Analyze_Initialization_Item
;
3058 ---------------------------------------------
3059 -- Analyze_Initialization_Item_With_Inputs --
3060 ---------------------------------------------
3062 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
3063 Inputs_Seen
: Elist_Id
:= No_Elist
;
3064 -- A list of all inputs processed so far. This list is used to detect
3065 -- duplicate uses of an input.
3067 Non_Null_Seen
: Boolean := False;
3068 Null_Seen
: Boolean := False;
3069 -- Flags used to check the legality of an input list
3071 procedure Analyze_Input_Item
(Input
: Node_Id
);
3072 -- Verify the legality of a single input item
3074 ------------------------
3075 -- Analyze_Input_Item --
3076 ------------------------
3078 procedure Analyze_Input_Item
(Input
: Node_Id
) is
3079 Input_Id
: Entity_Id
;
3084 if Nkind
(Input
) = N_Null
then
3087 ("multiple null initializations not allowed", Item
);
3089 elsif Non_Null_Seen
then
3091 ("cannot mix null and non-null initialization item", Item
);
3099 Non_Null_Seen
:= True;
3103 ("cannot mix null and non-null initialization item", Item
);
3107 Resolve_State
(Input
);
3109 if Is_Entity_Name
(Input
) then
3110 Input_Id
:= Entity_Of
(Input
);
3112 if Present
(Input_Id
)
3113 and then Ekind
(Input_Id
) in E_Abstract_State
3115 | E_Generic_In_Out_Parameter
3116 | E_Generic_In_Parameter
3118 | E_In_Out_Parameter
3124 -- The input cannot denote states or objects declared
3125 -- within the related package (SPARK RM 7.1.5(4)).
3127 if Within_Scope
(Input_Id
, Current_Scope
) then
3129 -- Do not consider generic formal parameters or their
3130 -- respective mappings to generic formals. Even though
3131 -- the formals appear within the scope of the package,
3132 -- it is allowed for an initialization item to depend
3133 -- on an input item.
3135 if Is_Formal_Object
(Input_Id
) then
3138 elsif Ekind
(Input_Id
) in E_Constant | E_Variable
3139 and then Present
(Corresponding_Generic_Association
3140 (Declaration_Node
(Input_Id
)))
3145 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3147 ("input item & cannot denote a visible object or "
3148 & "state of package %", Input
, Input_Id
);
3153 if Ekind
(Input_Id
) in E_Constant | E_Variable
3154 and then Present
(Ultimate_Overlaid_Entity
(Input_Id
))
3157 ("overlaying object & cannot appear in Initializes",
3160 ("\use the overlaid object & instead",
3161 Input
, Ultimate_Overlaid_Entity
(Input_Id
));
3165 -- Detect a duplicate use of the same input item
3166 -- (SPARK RM 7.1.5(5)).
3168 if Contains
(Inputs_Seen
, Input_Id
) then
3169 SPARK_Msg_N
("duplicate input item", Input
);
3173 -- At this point it is known that the input is legal. Add
3174 -- it to the list of processed inputs.
3176 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
3178 if Ekind
(Input_Id
) = E_Abstract_State
then
3179 Append_New_Elmt
(Input_Id
, States_Seen
);
3182 if Ekind
(Input_Id
) in E_Abstract_State
3185 and then Present
(Encapsulating_State
(Input_Id
))
3187 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3190 -- The input references something that is not a state or an
3191 -- object (SPARK RM 7.1.5(3)).
3195 ("input item must denote object or state", Input
);
3198 -- Some form of illegal construct masquerading as a name
3199 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3203 ("input item must denote object or state", Input
);
3206 end Analyze_Input_Item
;
3210 Inputs
: constant Node_Id
:= Expression
(Item
);
3214 Name_Seen
: Boolean := False;
3215 -- A flag used to detect multiple item names
3217 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3220 -- Inspect the name of an item with inputs
3222 Elmt
:= First
(Choices
(Item
));
3223 while Present
(Elmt
) loop
3225 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3228 Analyze_Initialization_Item
(Elmt
);
3234 -- Multiple input items appear as an aggregate
3236 if Nkind
(Inputs
) = N_Aggregate
then
3237 if Present
(Expressions
(Inputs
)) then
3238 Input
:= First
(Expressions
(Inputs
));
3239 while Present
(Input
) loop
3240 Analyze_Input_Item
(Input
);
3245 if Present
(Component_Associations
(Inputs
)) then
3247 ("inputs must appear in named association form", Inputs
);
3250 -- Single input item
3253 Analyze_Input_Item
(Inputs
);
3255 end Analyze_Initialization_Item_With_Inputs
;
3257 --------------------------------
3258 -- Collect_States_And_Objects --
3259 --------------------------------
3261 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
) is
3262 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3263 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3265 State_Elmt
: Elmt_Id
;
3268 -- Collect the abstract states defined in the package (if any)
3270 if Has_Non_Null_Abstract_State
(Pack_Id
) then
3271 State_Elmt
:= First_Elmt
(Abstract_States
(Pack_Id
));
3272 while Present
(State_Elmt
) loop
3273 Append_New_Elmt
(Node
(State_Elmt
), States_And_Objs
);
3274 Next_Elmt
(State_Elmt
);
3278 -- Collect all objects that appear in the visible declarations of the
3281 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3282 while Present
(Decl
) loop
3283 if Comes_From_Source
(Decl
)
3284 and then Nkind
(Decl
) in N_Object_Declaration
3285 | N_Object_Renaming_Declaration
3287 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3289 elsif Nkind
(Decl
) = N_Package_Declaration
then
3290 Collect_States_And_Objects
(Decl
);
3292 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3294 (Anonymous_Object
(Defining_Entity
(Decl
)),
3300 end Collect_States_And_Objects
;
3304 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3307 -- Start of processing for Analyze_Initializes_In_Decl_Part
3310 -- Do not analyze the pragma multiple times
3312 if Is_Analyzed_Pragma
(N
) then
3316 -- Nothing to do when the initialization list is empty
3318 if Nkind
(Inits
) = N_Null
then
3322 -- Single and multiple initialization clauses appear as an aggregate. If
3323 -- this is not the case, then either the parser or the analysis of the
3324 -- pragma failed to produce an aggregate.
3326 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3328 -- Initialize the various lists used during analysis
3330 Collect_States_And_Objects
(Pack_Decl
);
3332 if Present
(Expressions
(Inits
)) then
3333 Init
:= First
(Expressions
(Inits
));
3334 while Present
(Init
) loop
3335 Analyze_Initialization_Item
(Init
);
3340 if Present
(Component_Associations
(Inits
)) then
3341 Init
:= First
(Component_Associations
(Inits
));
3342 while Present
(Init
) loop
3343 Analyze_Initialization_Item_With_Inputs
(Init
);
3348 -- Ensure that a state and a corresponding constituent do not appear
3349 -- together in pragma Initializes.
3351 Check_State_And_Constituent_Use
3352 (States
=> States_Seen
,
3353 Constits
=> Constits_Seen
,
3356 Set_Is_Analyzed_Pragma
(N
);
3357 end Analyze_Initializes_In_Decl_Part
;
3359 ---------------------
3360 -- Analyze_Part_Of --
3361 ---------------------
3363 procedure Analyze_Part_Of
3365 Item_Id
: Entity_Id
;
3367 Encap_Id
: out Entity_Id
;
3368 Legal
: out Boolean)
3370 procedure Check_Part_Of_Abstract_State
;
3371 pragma Inline
(Check_Part_Of_Abstract_State
);
3372 -- Verify the legality of indicator Part_Of when the encapsulator is an
3375 procedure Check_Part_Of_Concurrent_Type
;
3376 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3377 -- Verify the legality of indicator Part_Of when the encapsulator is a
3378 -- single concurrent type.
3380 ----------------------------------
3381 -- Check_Part_Of_Abstract_State --
3382 ----------------------------------
3384 procedure Check_Part_Of_Abstract_State
is
3385 Pack_Id
: Entity_Id
;
3386 Placement
: State_Space_Kind
;
3387 Parent_Unit
: Entity_Id
;
3390 -- Determine where the object, package instantiation or state lives
3391 -- with respect to the enclosing packages or package bodies.
3393 Find_Placement_In_State_Space
3394 (Item_Id
=> Item_Id
,
3395 Placement
=> Placement
,
3396 Pack_Id
=> Pack_Id
);
3398 -- The item appears in a non-package construct with a declarative
3399 -- part (subprogram, block, etc). As such, the item is not allowed
3400 -- to be a part of an encapsulating state because the item is not
3403 if Placement
= Not_In_Package
then
3405 ("indicator Part_Of cannot appear in this context "
3406 & "(SPARK RM 7.2.6(5))", Indic
);
3408 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3410 ("\& is not part of the hidden state of package %",
3414 -- The item appears in the visible state space of some package. In
3415 -- general this scenario does not warrant Part_Of except when the
3416 -- package is a nongeneric private child unit and the encapsulating
3417 -- state is declared in a parent unit or a public descendant of that
3420 elsif Placement
= Visible_State_Space
then
3421 if Is_Child_Unit
(Pack_Id
)
3422 and then not Is_Generic_Unit
(Pack_Id
)
3423 and then Is_Private_Descendant
(Pack_Id
)
3425 -- A variable or state abstraction which is part of the visible
3426 -- state of a nongeneric private child unit or its public
3427 -- descendants must have its Part_Of indicator specified. The
3428 -- Part_Of indicator must denote a state declared by either the
3429 -- parent unit of the private unit or by a public descendant of
3430 -- that parent unit.
3432 -- Find the nearest private ancestor (which can be the current
3435 Parent_Unit
:= Pack_Id
;
3436 while Present
(Parent_Unit
) loop
3437 exit when Is_Private_Library_Unit
(Parent_Unit
);
3438 Parent_Unit
:= Scope
(Parent_Unit
);
3441 Parent_Unit
:= Scope
(Parent_Unit
);
3443 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3445 ("indicator Part_Of must denote abstract state of & or of "
3446 & "its public descendant (SPARK RM 7.2.6(3))",
3447 Indic
, Parent_Unit
);
3450 elsif Scope
(Encap_Id
) = Parent_Unit
3452 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3453 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3459 ("indicator Part_Of must denote abstract state of & or of "
3460 & "its public descendant (SPARK RM 7.2.6(3))",
3461 Indic
, Parent_Unit
);
3465 -- Indicator Part_Of is not needed when the related package is
3466 -- not a nongeneric private child unit or a public descendant
3471 ("indicator Part_Of cannot appear in this context "
3472 & "(SPARK RM 7.2.6(5))", Indic
);
3474 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3476 ("\& is declared in the visible part of package %",
3481 -- When the item appears in the private state space of a package, the
3482 -- encapsulating state must be declared in the same package.
3484 elsif Placement
= Private_State_Space
then
3486 -- In the case of the abstract state of a nongeneric private
3487 -- child package, it may be encapsulated in the state of a
3488 -- public descendant of its parent package.
3491 function Is_Public_Descendant
3492 (Child
, Ancestor
: Entity_Id
)
3494 -- Return True if Child is a public descendant of Pack
3496 --------------------------
3497 -- Is_Public_Descendant --
3498 --------------------------
3500 function Is_Public_Descendant
3501 (Child
, Ancestor
: Entity_Id
)
3504 P
: Entity_Id
:= Child
;
3506 while Is_Child_Unit
(P
)
3507 and then not Is_Private_Library_Unit
(P
)
3509 if Scope
(P
) = Ancestor
then
3517 end Is_Public_Descendant
;
3521 Immediate_Pack_Id
: constant Entity_Id
:= Scope
(Item_Id
);
3523 Is_State_Of_Private_Child
: constant Boolean :=
3524 Is_Child_Unit
(Immediate_Pack_Id
)
3525 and then not Is_Generic_Unit
(Immediate_Pack_Id
)
3526 and then Is_Private_Descendant
(Immediate_Pack_Id
);
3528 Is_OK_Through_Sibling
: Boolean := False;
3531 if Ekind
(Item_Id
) = E_Abstract_State
3532 and then Is_State_Of_Private_Child
3533 and then Is_Public_Descendant
(Scope
(Encap_Id
), Pack_Id
)
3535 Is_OK_Through_Sibling
:= True;
3538 if Scope
(Encap_Id
) /= Pack_Id
3539 and then not Is_OK_Through_Sibling
3541 if Is_State_Of_Private_Child
then
3543 ("indicator Part_Of must denote abstract state of & "
3544 & "or of its public descendant "
3545 & "(SPARK RM 7.2.6(3))", Indic
, Pack_Id
);
3548 ("indicator Part_Of must denote an abstract state of "
3549 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3552 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3554 ("\& is declared in the private part of package %",
3560 -- Items declared in the body state space of a package do not need
3561 -- Part_Of indicators as the refinement has already been seen.
3565 ("indicator Part_Of cannot appear in this context "
3566 & "(SPARK RM 7.2.6(5))", Indic
);
3568 if Scope
(Encap_Id
) = Pack_Id
then
3569 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3571 ("\& is declared in the body of package %", Indic
, Item_Id
);
3577 -- In the case of state in a (descendant of a private) child which
3578 -- is Part_Of the state of another package, the package defining the
3579 -- encapsulating abstract state should have a body, to ensure that it
3580 -- has a state refinement (SPARK RM 7.1.4(4)).
3582 if Enclosing_Comp_Unit_Node
(Encap_Id
) /=
3583 Enclosing_Comp_Unit_Node
(Item_Id
)
3584 and then not Unit_Requires_Body
(Scope
(Encap_Id
))
3587 ("indicator Part_Of must denote abstract state of package "
3588 & "with a body (SPARK RM 7.1.4(4))", Indic
);
3592 -- At this point it is known that the Part_Of indicator is legal
3595 end Check_Part_Of_Abstract_State
;
3597 -----------------------------------
3598 -- Check_Part_Of_Concurrent_Type --
3599 -----------------------------------
3601 procedure Check_Part_Of_Concurrent_Type
is
3602 function In_Proper_Order
3604 Second
: Node_Id
) return Boolean;
3605 pragma Inline
(In_Proper_Order
);
3606 -- Determine whether node First precedes node Second
3608 procedure Placement_Error
;
3609 pragma Inline
(Placement_Error
);
3610 -- Emit an error concerning the illegal placement of the item with
3611 -- respect to the single concurrent type.
3613 ---------------------
3614 -- In_Proper_Order --
3615 ---------------------
3617 function In_Proper_Order
3619 Second
: Node_Id
) return Boolean
3624 if List_Containing
(First
) = List_Containing
(Second
) then
3626 while Present
(N
) loop
3636 end In_Proper_Order
;
3638 ---------------------
3639 -- Placement_Error --
3640 ---------------------
3642 procedure Placement_Error
is
3645 ("indicator Part_Of must denote a previously declared single "
3646 & "protected type or single task type", Encap
);
3647 end Placement_Error
;
3651 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3652 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3653 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3655 Item_Context
: Node_Id
;
3656 Item_Decl
: Node_Id
;
3657 Prv_Decls
: List_Id
;
3658 Vis_Decls
: List_Id
;
3660 -- Start of processing for Check_Part_Of_Concurrent_Type
3663 -- Only abstract states and variables can act as constituents of an
3664 -- encapsulating single concurrent type.
3666 if Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
3669 -- The constituent is a constant
3671 elsif Ekind
(Item_Id
) = E_Constant
then
3672 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3674 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3675 & "single protected type %"), Indic
, Item_Id
);
3678 -- The constituent is a package instantiation
3681 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3683 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3684 & "constituent of single protected type %"), Indic
, Item_Id
);
3688 -- When the item denotes an abstract state of a nested package, use
3689 -- the declaration of the package to detect proper placement.
3694 -- with Abstract_State => (State with Part_Of => T)
3696 if Ekind
(Item_Id
) = E_Abstract_State
then
3697 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3699 Item_Decl
:= Declaration_Node
(Item_Id
);
3702 Item_Context
:= Parent
(Item_Decl
);
3704 -- The item and the single concurrent type must appear in the same
3705 -- declarative region, with the item following the declaration of
3706 -- the single concurrent type (SPARK RM 9(3)).
3708 if Item_Context
= Encap_Context
then
3709 if Nkind
(Item_Context
) in N_Package_Specification
3710 | N_Protected_Definition
3713 Prv_Decls
:= Private_Declarations
(Item_Context
);
3714 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3716 -- The placement is OK when the single concurrent type appears
3717 -- within the visible declarations and the item in the private
3723 -- Constit : ... with Part_Of => PO;
3726 if List_Containing
(Encap_Decl
) = Vis_Decls
3727 and then List_Containing
(Item_Decl
) = Prv_Decls
3731 -- The placement is illegal when the item appears within the
3732 -- visible declarations and the single concurrent type is in
3733 -- the private declarations.
3736 -- Constit : ... with Part_Of => PO;
3741 elsif List_Containing
(Item_Decl
) = Vis_Decls
3742 and then List_Containing
(Encap_Decl
) = Prv_Decls
3747 -- Otherwise both the item and the single concurrent type are
3748 -- in the same list. Ensure that the declaration of the single
3749 -- concurrent type precedes that of the item.
3751 elsif not In_Proper_Order
3752 (First
=> Encap_Decl
,
3753 Second
=> Item_Decl
)
3759 -- Otherwise both the item and the single concurrent type are
3760 -- in the same list. Ensure that the declaration of the single
3761 -- concurrent type precedes that of the item.
3763 elsif not In_Proper_Order
3764 (First
=> Encap_Decl
,
3765 Second
=> Item_Decl
)
3771 -- Otherwise the item and the single concurrent type reside within
3772 -- unrelated regions.
3775 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3777 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3778 & "immediately within the same region as single protected "
3779 & "type %"), Indic
, Item_Id
);
3783 -- At this point it is known that the Part_Of indicator is legal
3786 end Check_Part_Of_Concurrent_Type
;
3788 -- Start of processing for Analyze_Part_Of
3791 -- Assume that the indicator is illegal
3797 N_Expanded_Name | N_Identifier | N_Selected_Component
3800 Resolve_State
(Encap
);
3802 Encap_Id
:= Entity
(Encap
);
3804 -- The encapsulator is an abstract state
3806 if Ekind
(Encap_Id
) = E_Abstract_State
then
3809 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3811 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3814 -- Otherwise the encapsulator is not a legal choice
3818 ("indicator Part_Of must denote abstract state, single "
3819 & "protected type or single task type", Encap
);
3823 -- This is a syntax error, always report
3827 ("indicator Part_Of must denote abstract state, single protected "
3828 & "type or single task type", Encap
);
3832 -- Catch a case where indicator Part_Of denotes the abstract view of a
3833 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3835 if From_Limited_With
(Encap_Id
)
3836 and then Present
(Non_Limited_View
(Encap_Id
))
3837 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3839 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3840 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3844 -- The encapsulator is an abstract state
3846 if Ekind
(Encap_Id
) = E_Abstract_State
then
3847 Check_Part_Of_Abstract_State
;
3849 -- The encapsulator is a single concurrent type
3852 Check_Part_Of_Concurrent_Type
;
3854 end Analyze_Part_Of
;
3856 ----------------------------------
3857 -- Analyze_Part_Of_In_Decl_Part --
3858 ----------------------------------
3860 procedure Analyze_Part_Of_In_Decl_Part
3862 Freeze_Id
: Entity_Id
:= Empty
)
3864 Encap
: constant Node_Id
:=
3865 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3866 Errors
: constant Nat
:= Serious_Errors_Detected
;
3867 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3868 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3869 Constits
: Elist_Id
;
3870 Encap_Id
: Entity_Id
;
3874 -- Detect any discrepancies between the placement of the variable with
3875 -- respect to general state space and the encapsulating state or single
3882 Encap_Id
=> Encap_Id
,
3885 -- The Part_Of indicator turns the variable into a constituent of the
3886 -- encapsulating state or single concurrent type.
3889 pragma Assert
(Present
(Encap_Id
));
3890 Constits
:= Part_Of_Constituents
(Encap_Id
);
3892 if No
(Constits
) then
3893 Constits
:= New_Elmt_List
;
3894 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3897 Append_Elmt
(Var_Id
, Constits
);
3898 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3900 -- A Part_Of constituent partially refines an abstract state. This
3901 -- property does not apply to protected or task units.
3903 if Ekind
(Encap_Id
) = E_Abstract_State
then
3904 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3908 -- Emit a clarification message when the encapsulator is undefined,
3909 -- possibly due to contract freezing.
3911 if Errors
/= Serious_Errors_Detected
3912 and then Present
(Freeze_Id
)
3913 and then Has_Undefined_Reference
(Encap
)
3915 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3917 end Analyze_Part_Of_In_Decl_Part
;
3919 --------------------
3920 -- Analyze_Pragma --
3921 --------------------
3923 procedure Analyze_Pragma
(N
: Node_Id
) is
3924 Loc
: constant Source_Ptr
:= Sloc
(N
);
3926 Pname
: Name_Id
:= Pragma_Name
(N
);
3927 -- Name of the source pragma, or name of the corresponding aspect for
3928 -- pragmas which originate in a source aspect. In the latter case, the
3929 -- name may be different from the pragma name.
3931 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3933 Pragma_Exit
: exception;
3934 -- This exception is used to exit pragma processing completely. It
3935 -- is used when an error is detected, and no further processing is
3936 -- required. It is also used if an earlier error has left the tree in
3937 -- a state where the pragma should not be processed.
3940 -- Number of pragma argument associations
3947 -- First five pragma arguments (pragma argument association nodes, or
3948 -- Empty if the corresponding argument does not exist).
3950 type Name_List
is array (Natural range <>) of Name_Id
;
3951 type Args_List
is array (Natural range <>) of Node_Id
;
3952 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3954 -----------------------
3955 -- Local Subprograms --
3956 -----------------------
3958 procedure Ada_2005_Pragma
;
3959 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3960 -- Ada 95 mode, these are implementation defined pragmas, so should be
3961 -- caught by the No_Implementation_Pragmas restriction.
3963 procedure Ada_2012_Pragma
;
3964 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3965 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3966 -- should be caught by the No_Implementation_Pragmas restriction.
3968 procedure Analyze_Depends_Global
3969 (Spec_Id
: out Entity_Id
;
3970 Subp_Decl
: out Node_Id
;
3971 Legal
: out Boolean);
3972 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3973 -- legality of the placement and related context of the pragma. Spec_Id
3974 -- is the entity of the related subprogram. Subp_Decl is the declaration
3975 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3977 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3978 -- Inspect the remainder of the list containing pragma N and look for
3979 -- a pragma that matches Id. If found, analyze the pragma.
3981 procedure Analyze_Pre_Post_Condition
;
3982 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3984 procedure Analyze_Refined_Depends_Global_Post
3985 (Spec_Id
: out Entity_Id
;
3986 Body_Id
: out Entity_Id
;
3987 Legal
: out Boolean);
3988 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3989 -- Refined_Global and Refined_Post. Verify the legality of the placement
3990 -- and related context of the pragma. Spec_Id is the entity of the
3991 -- related subprogram. Body_Id is the entity of the subprogram body.
3992 -- Flag Legal is set when the pragma is legal.
3994 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3995 -- Perform full analysis of pragma Unmodified and the write aspect of
3996 -- pragma Unused. Flag Is_Unused should be set when verifying the
3997 -- semantics of pragma Unused.
3999 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
4000 -- Perform full analysis of pragma Unreferenced and the read aspect of
4001 -- pragma Unused. Flag Is_Unused should be set when verifying the
4002 -- semantics of pragma Unused.
4004 procedure Check_Ada_83_Warning
;
4005 -- Issues a warning message for the current pragma if operating in Ada
4006 -- 83 mode (used for language pragmas that are not a standard part of
4007 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
4010 procedure Check_Arg_Count
(Required
: Nat
);
4011 -- Check argument count for pragma is equal to given parameter. If not,
4012 -- then issue an error message and raise Pragma_Exit.
4014 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
4015 -- Arg which can either be a pragma argument association, in which case
4016 -- the check is applied to the expression of the association or an
4017 -- expression directly.
4019 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
4020 -- Check that an argument has the right form for an EXTERNAL_NAME
4021 -- parameter of an extended import/export pragma. The rule is that the
4022 -- name must be an identifier or string literal (in Ada 83 mode) or a
4023 -- static string expression (in Ada 95 mode).
4025 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
4026 -- Check the specified argument Arg to make sure that it is an
4027 -- identifier. If not give error and raise Pragma_Exit.
4029 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
4030 -- Check the specified argument Arg to make sure that it is an integer
4031 -- literal. If not give error and raise Pragma_Exit.
4033 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
4034 -- Check the specified argument Arg to make sure that it has the proper
4035 -- syntactic form for a local name and meets the semantic requirements
4036 -- for a local name. The local name is analyzed as part of the
4037 -- processing for this call. In addition, the local name is required
4038 -- to represent an entity at the library level.
4040 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
4041 -- Check the specified argument Arg to make sure that it has the proper
4042 -- syntactic form for a local name and meets the semantic requirements
4043 -- for a local name. The local name is analyzed as part of the
4044 -- processing for this call.
4046 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
4047 -- Check the specified argument Arg to make sure that it is a valid
4048 -- locking policy name. If not give error and raise Pragma_Exit.
4050 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
4051 -- Check the specified argument Arg to make sure that it is a valid
4052 -- elaboration policy name. If not give error and raise Pragma_Exit.
4054 procedure Check_Arg_Is_One_Of
4057 procedure Check_Arg_Is_One_Of
4059 N1
, N2
, N3
: Name_Id
);
4060 procedure Check_Arg_Is_One_Of
4062 N1
, N2
, N3
, N4
: Name_Id
);
4063 procedure Check_Arg_Is_One_Of
4065 N1
, N2
, N3
, N4
, N5
: Name_Id
);
4066 -- Check the specified argument Arg to make sure that it is an
4067 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
4068 -- present). If not then give error and raise Pragma_Exit.
4070 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
4071 -- Check the specified argument Arg to make sure that it is a valid
4072 -- queuing policy name. If not give error and raise Pragma_Exit.
4074 procedure Check_Arg_Is_OK_Static_Expression
4076 Typ
: Entity_Id
:= Empty
);
4077 -- Check the specified argument Arg to make sure that it is a static
4078 -- expression of the given type (i.e. it will be analyzed and resolved
4079 -- using this type, which can be any valid argument to Resolve, e.g.
4080 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4081 -- Typ is left Empty, then any static expression is allowed. Includes
4082 -- checking that the argument does not raise Constraint_Error.
4084 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
4085 -- Check the specified argument Arg to make sure that it is a valid task
4086 -- dispatching policy name. If not give error and raise Pragma_Exit.
4088 procedure Check_Arg_Order
(Names
: Name_List
);
4089 -- Checks for an instance of two arguments with identifiers for the
4090 -- current pragma which are not in the sequence indicated by Names,
4091 -- and if so, generates a fatal message about bad order of arguments.
4093 procedure Check_At_Least_N_Arguments
(N
: Nat
);
4094 -- Check there are at least N arguments present
4096 procedure Check_At_Most_N_Arguments
(N
: Nat
);
4097 -- Check there are no more than N arguments present
4099 procedure Check_Component
4102 In_Variant_Part
: Boolean := False);
4103 -- Examine an Unchecked_Union component for correct use of per-object
4104 -- constrained subtypes, and for restrictions on finalizable components.
4105 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
4106 -- should be set when Comp comes from a record variant.
4108 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
4109 -- Check if a rep item of the same name as the current pragma is already
4110 -- chained as a rep pragma to the given entity. If so give a message
4111 -- about the duplicate, and then raise Pragma_Exit so does not return.
4112 -- Note that if E is a type, then this routine avoids flagging a pragma
4113 -- which applies to a parent type from which E is derived.
4115 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
4116 -- Nam is an N_String_Literal node containing the external name set by
4117 -- an Import or Export pragma (or extended Import or Export pragma).
4118 -- This procedure checks for possible duplications if this is the export
4119 -- case, and if found, issues an appropriate error message.
4121 procedure Check_Expr_Is_OK_Static_Expression
4123 Typ
: Entity_Id
:= Empty
);
4124 -- Check the specified expression Expr to make sure that it is a static
4125 -- expression of the given type (i.e. it will be analyzed and resolved
4126 -- using this type, which can be any valid argument to Resolve, e.g.
4127 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4128 -- Typ is left Empty, then any static expression is allowed. Includes
4129 -- checking that the expression does not raise Constraint_Error.
4131 procedure Check_First_Subtype
(Arg
: Node_Id
);
4132 -- Checks that Arg, whose expression is an entity name, references a
4135 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4136 -- Checks that the given argument has an identifier, and if so, requires
4137 -- it to match the given identifier name. If there is no identifier, or
4138 -- a non-matching identifier, then an error message is given and
4139 -- Pragma_Exit is raised.
4141 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
4142 -- Checks that the given argument has an identifier, and if so, requires
4143 -- it to match one of the given identifier names. If there is no
4144 -- identifier, or a non-matching identifier, then an error message is
4145 -- given and Pragma_Exit is raised.
4147 procedure Check_In_Main_Program
;
4148 -- Common checks for pragmas that appear within a main program
4149 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4151 procedure Check_Interrupt_Or_Attach_Handler
;
4152 -- Common processing for first argument of pragma Interrupt_Handler or
4153 -- pragma Attach_Handler.
4155 procedure Check_Loop_Pragma_Placement
;
4156 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4157 -- appear immediately within a construct restricted to loops, and that
4158 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4160 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
4161 -- Check that pragma appears in a declarative part, or in a package
4162 -- specification, i.e. that it does not occur in a statement sequence
4165 procedure Check_No_Identifier
(Arg
: Node_Id
);
4166 -- Checks that the given argument does not have an identifier. If
4167 -- an identifier is present, then an error message is issued, and
4168 -- Pragma_Exit is raised.
4170 procedure Check_No_Identifiers
;
4171 -- Checks that none of the arguments to the pragma has an identifier.
4172 -- If any argument has an identifier, then an error message is issued,
4173 -- and Pragma_Exit is raised.
4175 procedure Check_No_Link_Name
;
4176 -- Checks that no link name is specified
4178 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4179 -- Checks if the given argument has an identifier, and if so, requires
4180 -- it to match the given identifier name. If there is a non-matching
4181 -- identifier, then an error message is given and Pragma_Exit is raised.
4183 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
4184 -- Checks if the given argument has an identifier, and if so, requires
4185 -- it to match the given identifier name. If there is a non-matching
4186 -- identifier, then an error message is given and Pragma_Exit is raised.
4187 -- In this version of the procedure, the identifier name is given as
4188 -- a string with lower case letters.
4190 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
4191 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4192 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4193 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4194 -- is an OK static boolean expression. Emit an error if this is not the
4197 procedure Check_Static_Constraint
(Constr
: Node_Id
);
4198 -- Constr is a constraint from an N_Subtype_Indication node from a
4199 -- component constraint in an Unchecked_Union type, a range, or a
4200 -- discriminant association. This routine checks that the constraint
4201 -- is static as required by the restrictions for Unchecked_Union.
4203 procedure Check_Valid_Configuration_Pragma
;
4204 -- Legality checks for placement of a configuration pragma
4206 procedure Check_Valid_Library_Unit_Pragma
;
4207 -- Legality checks for library unit pragmas. A special case arises for
4208 -- pragmas in generic instances that come from copies of the original
4209 -- library unit pragmas in the generic templates. In the case of other
4210 -- than library level instantiations these can appear in contexts which
4211 -- would normally be invalid (they only apply to the original template
4212 -- and to library level instantiations), and they are simply ignored,
4213 -- which is implemented by rewriting them as null statements and
4214 -- optionally raising Pragma_Exit to terminate analysis. An exception
4215 -- is not always raised to avoid exception propagation during the
4216 -- bootstrap, so all callers should check whether N has been rewritten.
4218 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
4219 -- Check an Unchecked_Union variant for lack of nested variants and
4220 -- presence of at least one component. UU_Typ is the related Unchecked_
4223 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
4224 -- Subsidiary routine to the processing of pragmas Abstract_State,
4225 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4226 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4227 -- argument Arg into an aggregate if not one already. N_Null is never
4228 -- transformed. Arg may denote an aspect specification or a pragma
4229 -- argument association.
4231 procedure Error_Pragma
(Msg
: String);
4232 pragma No_Return
(Error_Pragma
);
4233 -- Outputs error message for current pragma. The message contains a %
4234 -- that will be replaced with the pragma name, and the flag is placed
4235 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4236 -- calls Fix_Error (see spec of that procedure for details).
4238 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
4239 pragma No_Return
(Error_Pragma_Arg
);
4240 -- Outputs error message for current pragma. The message may contain
4241 -- a % that will be replaced with the pragma name. The parameter Arg
4242 -- may either be a pragma argument association, in which case the flag
4243 -- is placed on the expression of this association, or an expression,
4244 -- in which case the flag is placed directly on the expression. The
4245 -- message is placed using Error_Msg_N, so the message may also contain
4246 -- an & insertion character which will reference the given Arg value.
4247 -- After placing the message, Pragma_Exit is raised. Note: this routine
4248 -- calls Fix_Error (see spec of that procedure for details).
4250 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
4251 pragma No_Return
(Error_Pragma_Arg
);
4252 -- Similar to above form of Error_Pragma_Arg except that two messages
4253 -- are provided, the second is a continuation comment starting with \.
4255 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
4256 pragma No_Return
(Error_Pragma_Arg_Ident
);
4257 -- Outputs error message for current pragma. The message may contain a %
4258 -- that will be replaced with the pragma name. The parameter Arg must be
4259 -- a pragma argument association with a non-empty identifier (i.e. its
4260 -- Chars field must be set), and the error message is placed on the
4261 -- identifier. The message is placed using Error_Msg_N so the message
4262 -- may also contain an & insertion character which will reference
4263 -- the identifier. After placing the message, Pragma_Exit is raised.
4264 -- Note: this routine calls Fix_Error (see spec of that procedure for
4267 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4268 pragma No_Return
(Error_Pragma_Ref
);
4269 -- Outputs error message for current pragma. The message may contain
4270 -- a % that will be replaced with the pragma name. The parameter Ref
4271 -- must be an entity whose name can be referenced by & and sloc by #.
4272 -- After placing the message, Pragma_Exit is raised. Note: this routine
4273 -- calls Fix_Error (see spec of that procedure for details).
4275 function Find_Lib_Unit_Name
return Entity_Id
;
4276 -- Used for a library unit pragma to find the entity to which the
4277 -- library unit pragma applies, returns the entity found.
4279 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4280 -- If the pragma is a compilation unit pragma, the id must denote the
4281 -- compilation unit in the same compilation, and the pragma must appear
4282 -- in the list of preceding or trailing pragmas. If it is a program
4283 -- unit pragma that is not a compilation unit pragma, then the
4284 -- identifier must be visible.
4286 function Find_Unique_Parameterless_Procedure
4288 Arg
: Node_Id
) return Entity_Id
;
4289 -- Used for a procedure pragma to find the unique parameterless
4290 -- procedure identified by Name, returns it if it exists, otherwise
4291 -- errors out and uses Arg as the pragma argument for the message.
4293 function Fix_Error
(Msg
: String) return String;
4294 -- This is called prior to issuing an error message. Msg is the normal
4295 -- error message issued in the pragma case. This routine checks for the
4296 -- case of a pragma coming from an aspect in the source, and returns a
4297 -- message suitable for the aspect case as follows:
4299 -- Each substring "pragma" is replaced by "aspect"
4301 -- If "argument of" is at the start of the error message text, it is
4302 -- replaced by "entity for".
4304 -- If "argument" is at the start of the error message text, it is
4305 -- replaced by "entity".
4307 -- So for example, "argument of pragma X must be discrete type"
4308 -- returns "entity for aspect X must be a discrete type".
4310 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4311 -- be different from the pragma name). If the current pragma results
4312 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4313 -- original pragma name.
4315 procedure Gather_Associations
4317 Args
: out Args_List
);
4318 -- This procedure is used to gather the arguments for a pragma that
4319 -- permits arbitrary ordering of parameters using the normal rules
4320 -- for named and positional parameters. The Names argument is a list
4321 -- of Name_Id values that corresponds to the allowed pragma argument
4322 -- association identifiers in order. The result returned in Args is
4323 -- a list of corresponding expressions that are the pragma arguments.
4324 -- Note that this is a list of expressions, not of pragma argument
4325 -- associations (Gather_Associations has completely checked all the
4326 -- optional identifiers when it returns). An entry in Args is Empty
4327 -- on return if the corresponding argument is not present.
4329 procedure GNAT_Pragma
;
4330 -- Called for all GNAT defined pragmas to check the relevant restriction
4331 -- (No_Implementation_Pragmas).
4333 function Is_Before_First_Decl
4334 (Pragma_Node
: Node_Id
;
4335 Decls
: List_Id
) return Boolean;
4336 -- Return True if Pragma_Node is before the first declarative item in
4337 -- Decls where Decls is the list of declarative items.
4339 function Is_Configuration_Pragma
return Boolean;
4340 -- Determines if the placement of the current pragma is appropriate
4341 -- for a configuration pragma.
4343 function Is_In_Context_Clause
return Boolean;
4344 -- Returns True if pragma appears within the context clause of a unit,
4345 -- and False for any other placement (does not generate any messages).
4347 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4348 -- Analyzes the argument, and determines if it is a static string
4349 -- expression, returns True if so, False if non-static or not String.
4350 -- A special case is that a string literal returns True in Ada 83 mode
4351 -- (which has no such thing as static string expressions). Note that
4352 -- the call analyzes its argument, so this cannot be used for the case
4353 -- where an identifier might not be declared.
4355 procedure Pragma_Misplaced
;
4356 pragma No_Return
(Pragma_Misplaced
);
4357 -- Issue fatal error message for misplaced pragma
4359 procedure Process_Atomic_Independent_Shared_Volatile
;
4360 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4361 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4362 -- and treated as being identical in effect to pragma Atomic.
4364 procedure Process_Compile_Time_Warning_Or_Error
;
4365 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4367 procedure Process_Convention
4368 (C
: out Convention_Id
;
4369 Ent
: out Entity_Id
);
4370 -- Common processing for Convention, Interface, Import and Export.
4371 -- Checks first two arguments of pragma, and sets the appropriate
4372 -- convention value in the specified entity or entities. On return
4373 -- C is the convention, Ent is the referenced entity.
4375 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4376 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4377 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4379 procedure Process_Extended_Import_Export_Object_Pragma
4380 (Arg_Internal
: Node_Id
;
4381 Arg_External
: Node_Id
;
4382 Arg_Size
: Node_Id
);
4383 -- Common processing for the pragmas Import/Export_Object. The three
4384 -- arguments correspond to the three named parameters of the pragmas. An
4385 -- argument is empty if the corresponding parameter is not present in
4388 procedure Process_Extended_Import_Export_Internal_Arg
4389 (Arg_Internal
: Node_Id
:= Empty
);
4390 -- Common processing for all extended Import and Export pragmas. The
4391 -- argument is the pragma parameter for the Internal argument. If
4392 -- Arg_Internal is empty or inappropriate, an error message is posted.
4393 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4394 -- set to identify the referenced entity.
4396 procedure Process_Extended_Import_Export_Subprogram_Pragma
4397 (Arg_Internal
: Node_Id
;
4398 Arg_External
: Node_Id
;
4399 Arg_Parameter_Types
: Node_Id
;
4400 Arg_Result_Type
: Node_Id
:= Empty
;
4401 Arg_Mechanism
: Node_Id
;
4402 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4403 -- Common processing for all extended Import and Export pragmas applying
4404 -- to subprograms. The caller omits any arguments that do not apply to
4405 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4406 -- only in the Import_Function and Export_Function cases). The argument
4407 -- names correspond to the allowed pragma association identifiers.
4409 procedure Process_Generic_List
;
4410 -- Common processing for Share_Generic and Inline_Generic
4412 procedure Process_Import_Or_Interface
;
4413 -- Common processing for Import or Interface
4415 procedure Process_Import_Predefined_Type
;
4416 -- Processing for completing a type with pragma Import. This is used
4417 -- to declare types that match predefined C types, especially for cases
4418 -- without corresponding Ada predefined type.
4420 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4421 -- Inline status of a subprogram, indicated as follows:
4422 -- Suppressed: inlining is suppressed for the subprogram
4423 -- Disabled: no inlining is requested for the subprogram
4424 -- Enabled: inlining is requested/required for the subprogram
4426 procedure Process_Inline
(Status
: Inline_Status
);
4427 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4428 -- indicates the inline status specified by the pragma.
4430 procedure Process_Interface_Name
4431 (Subprogram_Def
: Entity_Id
;
4435 -- Given the last two arguments of pragma Import, pragma Export, or
4436 -- pragma Interface_Name, performs validity checks and sets the
4437 -- Interface_Name field of the given subprogram entity to the
4438 -- appropriate external or link name, depending on the arguments given.
4439 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4440 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4441 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4442 -- nor Link_Arg is present, the interface name is set to the default
4443 -- from the subprogram name. In addition, the pragma itself is passed
4444 -- to analyze any expressions in the case the pragma came from an aspect
4447 procedure Process_Interrupt_Or_Attach_Handler
;
4448 -- Common processing for Interrupt and Attach_Handler pragmas
4450 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4451 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4452 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4453 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4454 -- is not set in the Restrictions case.
4456 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4457 -- Common processing for Suppress and Unsuppress. The boolean parameter
4458 -- Suppress_Case is True for the Suppress case, and False for the
4461 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4462 -- Subsidiary to the analysis of pragmas Independent[_Components].
4463 -- Record such a pragma N applied to entity E for future checks.
4465 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4466 -- This procedure sets the Is_Exported flag for the given entity,
4467 -- checking that the entity was not previously imported. Arg is
4468 -- the argument that specified the entity. A check is also made
4469 -- for exporting inappropriate entities.
4471 procedure Set_Extended_Import_Export_External_Name
4472 (Internal_Ent
: Entity_Id
;
4473 Arg_External
: Node_Id
);
4474 -- Common processing for all extended import export pragmas. The first
4475 -- argument, Internal_Ent, is the internal entity, which has already
4476 -- been checked for validity by the caller. Arg_External is from the
4477 -- Import or Export pragma, and may be null if no External parameter
4478 -- was present. If Arg_External is present and is a non-null string
4479 -- (a null string is treated as the default), then the Interface_Name
4480 -- field of Internal_Ent is set appropriately.
4482 procedure Set_Imported
(E
: Entity_Id
);
4483 -- This procedure sets the Is_Imported flag for the given entity,
4484 -- checking that it is not previously exported or imported.
4486 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4487 -- Mech is a parameter passing mechanism (see Import_Function syntax
4488 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4489 -- has the right form, and if not issues an error message. If the
4490 -- argument has the right form then the Mechanism field of Ent is
4491 -- set appropriately.
4493 procedure Set_Rational_Profile
;
4494 -- Activate the set of configuration pragmas and permissions that make
4495 -- up the Rational profile.
4497 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4498 -- Activate the set of configuration pragmas and restrictions that make
4499 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4500 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4501 -- pragma node, which is used for error messages on any constructs
4502 -- violating the profile.
4504 ---------------------
4505 -- Ada_2005_Pragma --
4506 ---------------------
4508 procedure Ada_2005_Pragma
is
4510 if Ada_Version
<= Ada_95
then
4511 Check_Restriction
(No_Implementation_Pragmas
, N
);
4513 end Ada_2005_Pragma
;
4515 ---------------------
4516 -- Ada_2012_Pragma --
4517 ---------------------
4519 procedure Ada_2012_Pragma
is
4521 if Ada_Version
<= Ada_2005
then
4522 Check_Restriction
(No_Implementation_Pragmas
, N
);
4524 end Ada_2012_Pragma
;
4526 ----------------------------
4527 -- Analyze_Depends_Global --
4528 ----------------------------
4530 procedure Analyze_Depends_Global
4531 (Spec_Id
: out Entity_Id
;
4532 Subp_Decl
: out Node_Id
;
4533 Legal
: out Boolean)
4536 -- Assume that the pragma is illegal
4543 Check_Arg_Count
(1);
4545 -- Ensure the proper placement of the pragma. Depends/Global must be
4546 -- associated with a subprogram declaration or a body that acts as a
4549 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4553 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4556 -- Generic subprogram
4558 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4561 -- Object declaration of a single concurrent type
4563 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4564 and then Is_Single_Concurrent_Object
4565 (Unique_Defining_Entity
(Subp_Decl
))
4571 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4574 -- Abstract subprogram declaration
4576 elsif Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4579 -- Subprogram body acts as spec
4581 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4582 and then No
(Corresponding_Spec
(Subp_Decl
))
4586 -- Subprogram body stub acts as spec
4588 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4589 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4593 -- Subprogram declaration
4595 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4597 -- Pragmas Global and Depends are forbidden on null procedures
4598 -- (SPARK RM 6.1.2(2)).
4600 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4601 and then Null_Present
(Specification
(Subp_Decl
))
4603 Error_Msg_N
(Fix_Error
4604 ("pragma % cannot apply to null procedure"), N
);
4610 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4617 -- If we get here, then the pragma is legal
4620 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4622 -- When the related context is an entry, the entry must belong to a
4623 -- protected unit (SPARK RM 6.1.4(6)).
4625 if Is_Entry_Declaration
(Spec_Id
)
4626 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4630 -- When the related context is an anonymous object created for a
4631 -- simple concurrent type, the type must be a task
4632 -- (SPARK RM 6.1.4(6)).
4634 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4635 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4640 -- A pragma that applies to a Ghost entity becomes Ghost for the
4641 -- purposes of legality checks and removal of ignored Ghost code.
4643 Mark_Ghost_Pragma
(N
, Spec_Id
);
4644 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4645 end Analyze_Depends_Global
;
4647 ------------------------
4648 -- Analyze_If_Present --
4649 ------------------------
4651 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4655 pragma Assert
(Is_List_Member
(N
));
4657 -- Inspect the declarations or statements following pragma N looking
4658 -- for another pragma whose Id matches the caller's request. If it is
4659 -- available, analyze it.
4662 while Present
(Stmt
) loop
4663 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4664 Analyze_Pragma
(Stmt
);
4667 -- The first source declaration or statement immediately following
4668 -- N ends the region where a pragma may appear.
4670 elsif Comes_From_Source
(Stmt
) then
4676 end Analyze_If_Present
;
4678 --------------------------------
4679 -- Analyze_Pre_Post_Condition --
4680 --------------------------------
4682 procedure Analyze_Pre_Post_Condition
is
4683 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4684 Subp_Decl
: Node_Id
;
4685 Subp_Id
: Entity_Id
;
4687 Duplicates_OK
: Boolean := False;
4688 -- Flag set when a pre/postcondition allows multiple pragmas of the
4691 In_Body_OK
: Boolean := False;
4692 -- Flag set when a pre/postcondition is allowed to appear on a body
4693 -- even though the subprogram may have a spec.
4695 Is_Pre_Post
: Boolean := False;
4696 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4699 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4700 -- Implement rules in AI12-0131: an overriding operation can have
4701 -- a class-wide precondition only if one of its ancestors has an
4702 -- explicit class-wide precondition.
4704 -----------------------------
4705 -- Inherits_Class_Wide_Pre --
4706 -----------------------------
4708 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4709 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4712 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4715 -- Check ancestors on the overriding operation to examine the
4716 -- preconditions that may apply to them.
4718 while Present
(Prev
) loop
4719 Cont
:= Contract
(Prev
);
4720 if Present
(Cont
) then
4721 Prag
:= Pre_Post_Conditions
(Cont
);
4722 while Present
(Prag
) loop
4723 if Pragma_Name
(Prag
) = Name_Precondition
4724 and then Class_Present
(Prag
)
4729 Prag
:= Next_Pragma
(Prag
);
4733 -- For a type derived from a generic formal type, the operation
4734 -- inheriting the condition is a renaming, not an overriding of
4735 -- the operation of the formal. Ditto for an inherited
4736 -- operation which has no explicit contracts.
4738 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4739 or else not Comes_From_Source
(Prev
)
4741 Prev
:= Alias
(Prev
);
4743 Prev
:= Overridden_Operation
(Prev
);
4747 -- If the controlling type of the subprogram has progenitors, an
4748 -- interface operation implemented by the current operation may
4749 -- have a class-wide precondition.
4751 if Has_Interfaces
(Typ
) then
4756 Prim_Elmt
: Elmt_Id
;
4757 Prim_List
: Elist_Id
;
4760 Collect_Interfaces
(Typ
, Ints
);
4761 Elmt
:= First_Elmt
(Ints
);
4763 -- Iterate over the primitive operations of each interface
4765 while Present
(Elmt
) loop
4766 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4767 Prim_Elmt
:= First_Elmt
(Prim_List
);
4768 while Present
(Prim_Elmt
) loop
4769 Prim
:= Node
(Prim_Elmt
);
4770 if Chars
(Prim
) = Chars
(E
)
4771 and then Present
(Contract
(Prim
))
4772 and then Class_Present
4773 (Pre_Post_Conditions
(Contract
(Prim
)))
4778 Next_Elmt
(Prim_Elmt
);
4787 end Inherits_Class_Wide_Pre
;
4789 -- Start of processing for Analyze_Pre_Post_Condition
4792 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4793 -- offer uniformity among the various kinds of pre/postconditions by
4794 -- rewriting the pragma identifier. This allows the retrieval of the
4795 -- original pragma name by routine Original_Aspect_Pragma_Name.
4797 if Comes_From_Source
(N
) then
4798 if Pname
in Name_Pre | Name_Pre_Class
then
4799 Is_Pre_Post
:= True;
4800 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4801 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4803 elsif Pname
in Name_Post | Name_Post_Class
then
4804 Is_Pre_Post
:= True;
4805 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4806 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4810 -- Determine the semantics with respect to duplicates and placement
4811 -- in a body. Pragmas Precondition and Postcondition were introduced
4812 -- before aspects and are not subject to the same aspect-like rules.
4814 if Pname
in Name_Precondition | Name_Postcondition
then
4815 Duplicates_OK
:= True;
4821 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4822 -- argument without an identifier.
4825 Check_Arg_Count
(1);
4826 Check_No_Identifiers
;
4828 -- Pragmas Precondition and Postcondition have complex argument
4832 Check_At_Least_N_Arguments
(1);
4833 Check_At_Most_N_Arguments
(2);
4834 Check_Optional_Identifier
(Arg1
, Name_Check
);
4836 if Present
(Arg2
) then
4837 Check_Optional_Identifier
(Arg2
, Name_Message
);
4838 Preanalyze_Spec_Expression
4839 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4843 -- For a pragma PPC in the extended main source unit, record enabled
4845 -- ??? nothing checks that the pragma is in the main source unit
4847 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4848 Set_SCO_Pragma_Enabled
(Loc
);
4851 -- Ensure the proper placement of the pragma
4854 Find_Related_Declaration_Or_Body
4855 (N
, Do_Checks
=> not Duplicates_OK
);
4857 -- When a pre/postcondition pragma applies to an abstract subprogram,
4858 -- its original form must be an aspect with 'Class.
4860 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4861 if not From_Aspect_Specification
(N
) then
4863 ("pragma % cannot be applied to abstract subprogram");
4865 elsif not Class_Present
(N
) then
4867 ("aspect % requires ''Class for abstract subprogram");
4870 -- Entry declaration
4872 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4875 -- Generic subprogram declaration
4877 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4882 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4883 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4887 -- Subprogram body stub
4889 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4890 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4894 -- Subprogram declaration
4896 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4898 -- AI05-0230: When a pre/postcondition pragma applies to a null
4899 -- procedure, its original form must be an aspect with 'Class.
4901 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4902 and then Null_Present
(Specification
(Subp_Decl
))
4903 and then From_Aspect_Specification
(N
)
4904 and then not Class_Present
(N
)
4906 Error_Pragma
("aspect % requires ''Class for null procedure");
4909 -- Implement the legality checks mandated by AI12-0131:
4910 -- Pre'Class shall not be specified for an overriding primitive
4911 -- subprogram of a tagged type T unless the Pre'Class aspect is
4912 -- specified for the corresponding primitive subprogram of some
4916 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4919 if Class_Present
(N
)
4920 and then Pragma_Name
(N
) = Name_Precondition
4921 and then Present
(Overridden_Operation
(E
))
4922 and then not Inherits_Class_Wide_Pre
(E
)
4925 ("illegal class-wide precondition on overriding operation",
4926 Corresponding_Aspect
(N
));
4930 -- A renaming declaration may inherit a generated pragma, its
4931 -- placement comes from expansion, not from source.
4933 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4934 and then not Comes_From_Source
(N
)
4938 -- For Ada 2022, pre/postconditions can appear on formal subprograms
4940 elsif Nkind
(Subp_Decl
) = N_Formal_Concrete_Subprogram_Declaration
4941 and then Ada_Version
>= Ada_2022
4945 -- An access-to-subprogram type can have pre/postconditions, but
4946 -- these are transferred to the generated subprogram wrapper and
4949 -- Otherwise the placement of the pragma is illegal
4955 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4957 -- A pragma that applies to a Ghost entity becomes Ghost for the
4958 -- purposes of legality checks and removal of ignored Ghost code.
4960 Mark_Ghost_Pragma
(N
, Subp_Id
);
4962 -- Chain the pragma on the contract for further processing by
4963 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4965 Add_Contract_Item
(N
, Subp_Id
);
4967 -- Fully analyze the pragma when it appears inside an entry or
4968 -- subprogram body because it cannot benefit from forward references.
4970 if Nkind
(Subp_Decl
) in N_Entry_Body
4972 | N_Subprogram_Body_Stub
4974 -- The legality checks of pragmas Precondition and Postcondition
4975 -- are affected by the SPARK mode in effect and the volatility of
4976 -- the context. Analyze all pragmas in a specific order.
4978 Analyze_If_Present
(Pragma_SPARK_Mode
);
4979 Analyze_If_Present
(Pragma_Volatile_Function
);
4980 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4982 end Analyze_Pre_Post_Condition
;
4984 -----------------------------------------
4985 -- Analyze_Refined_Depends_Global_Post --
4986 -----------------------------------------
4988 procedure Analyze_Refined_Depends_Global_Post
4989 (Spec_Id
: out Entity_Id
;
4990 Body_Id
: out Entity_Id
;
4991 Legal
: out Boolean)
4993 Body_Decl
: Node_Id
;
4994 Spec_Decl
: Node_Id
;
4997 -- Assume that the pragma is illegal
5004 Check_Arg_Count
(1);
5005 Check_No_Identifiers
;
5007 -- Verify the placement of the pragma and check for duplicates. The
5008 -- pragma must apply to a subprogram body [stub].
5010 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
5012 if Nkind
(Body_Decl
) not in
5013 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
5014 N_Task_Body | N_Task_Body_Stub
5019 Body_Id
:= Defining_Entity
(Body_Decl
);
5020 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
5022 -- The pragma must apply to the second declaration of a subprogram.
5023 -- In other words, the body [stub] cannot acts as a spec.
5025 if No
(Spec_Id
) then
5026 Error_Pragma
("pragma % cannot apply to a stand alone body");
5028 -- Catch the case where the subprogram body is a subunit and acts as
5029 -- the third declaration of the subprogram.
5031 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5032 Error_Pragma
("pragma % cannot apply to a subunit");
5035 -- A refined pragma can only apply to the body [stub] of a subprogram
5036 -- declared in the visible part of a package. Retrieve the context of
5037 -- the subprogram declaration.
5039 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
5041 -- When dealing with protected entries or protected subprograms, use
5042 -- the enclosing protected type as the proper context.
5044 if Ekind
(Spec_Id
) in E_Entry
5048 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
5050 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
5053 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
5055 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
5056 & "subprogram declared in a package specification"));
5059 -- If we get here, then the pragma is legal
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
);
5068 if Pname
in Name_Refined_Depends | Name_Refined_Global
then
5069 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5071 end Analyze_Refined_Depends_Global_Post
;
5073 ----------------------------------
5074 -- Analyze_Unmodified_Or_Unused --
5075 ----------------------------------
5077 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
5082 Ghost_Error_Posted
: Boolean := False;
5083 -- Flag set when an error concerning the illegal mix of Ghost and
5084 -- non-Ghost variables is emitted.
5086 Ghost_Id
: Entity_Id
:= Empty
;
5087 -- The entity of the first Ghost variable encountered while
5088 -- processing the arguments of the pragma.
5092 Check_At_Least_N_Arguments
(1);
5094 -- Loop through arguments
5097 while Present
(Arg
) loop
5098 Check_No_Identifier
(Arg
);
5100 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5101 -- in fact generate reference, so that the entity will have a
5102 -- reference, which will inhibit any warnings about it not
5103 -- being referenced, and also properly show up in the ali file
5104 -- as a reference. But this reference is recorded before the
5105 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5106 -- generated for this reference.
5108 Check_Arg_Is_Local_Name
(Arg
);
5109 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5111 if Is_Entity_Name
(Arg_Expr
) then
5112 Arg_Id
:= Entity
(Arg_Expr
);
5114 -- Skip processing the argument if already flagged
5116 if Is_Assignable
(Arg_Id
)
5117 and then not Has_Pragma_Unmodified
(Arg_Id
)
5118 and then not Has_Pragma_Unused
(Arg_Id
)
5120 Set_Has_Pragma_Unmodified
(Arg_Id
);
5123 Set_Has_Pragma_Unused
(Arg_Id
);
5126 -- A pragma that applies to a Ghost entity becomes Ghost for
5127 -- the purposes of legality checks and removal of ignored
5130 Mark_Ghost_Pragma
(N
, Arg_Id
);
5132 -- Capture the entity of the first Ghost variable being
5133 -- processed for error detection purposes.
5135 if Is_Ghost_Entity
(Arg_Id
) then
5136 if No
(Ghost_Id
) then
5140 -- Otherwise the variable is non-Ghost. It is illegal to mix
5141 -- references to Ghost and non-Ghost entities
5144 elsif Present
(Ghost_Id
)
5145 and then not Ghost_Error_Posted
5147 Ghost_Error_Posted
:= True;
5149 Error_Msg_Name_1
:= Pname
;
5151 ("pragma % cannot mention ghost and non-ghost "
5154 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5155 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
5157 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5158 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
5161 -- Warn if already flagged as Unused or Unmodified
5163 elsif Has_Pragma_Unmodified
(Arg_Id
) then
5164 if Has_Pragma_Unused
(Arg_Id
) then
5166 (Fix_Error
("??pragma Unused already given for &!"),
5170 (Fix_Error
("??pragma Unmodified already given for &!"),
5174 -- Otherwise the pragma referenced an illegal entity
5178 ("pragma% can only be applied to a variable", Arg_Expr
);
5184 end Analyze_Unmodified_Or_Unused
;
5186 ------------------------------------
5187 -- Analyze_Unreferenced_Or_Unused --
5188 ------------------------------------
5190 procedure Analyze_Unreferenced_Or_Unused
5191 (Is_Unused
: Boolean := False)
5198 Ghost_Error_Posted
: Boolean := False;
5199 -- Flag set when an error concerning the illegal mix of Ghost and
5200 -- non-Ghost names is emitted.
5202 Ghost_Id
: Entity_Id
:= Empty
;
5203 -- The entity of the first Ghost name encountered while processing
5204 -- the arguments of the pragma.
5208 Check_At_Least_N_Arguments
(1);
5210 -- Check case of appearing within context clause
5212 if not Is_Unused
and then Is_In_Context_Clause
then
5214 -- The arguments must all be units mentioned in a with clause in
5215 -- the same context clause. Note that Par.Prag already checked
5216 -- that the arguments are either identifiers or selected
5220 while Present
(Arg
) loop
5221 Citem
:= First
(List_Containing
(N
));
5222 while Citem
/= N
loop
5223 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5225 if Nkind
(Citem
) = N_With_Clause
5226 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5228 Set_Has_Pragma_Unreferenced
5231 (Library_Unit
(Citem
))));
5232 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5241 ("argument of pragma% is not withed unit", Arg
);
5247 -- Case of not in list of context items
5251 while Present
(Arg
) loop
5252 Check_No_Identifier
(Arg
);
5254 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5255 -- in fact generate reference, so that the entity will have a
5256 -- reference, which will inhibit any warnings about it not
5257 -- being referenced, and also properly show up in the ali file
5258 -- as a reference. But this reference is recorded before the
5259 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5260 -- generated for this reference.
5262 Check_Arg_Is_Local_Name
(Arg
);
5263 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5265 if Is_Entity_Name
(Arg_Expr
) then
5266 Arg_Id
:= Entity
(Arg_Expr
);
5268 -- Warn if already flagged as Unused or Unreferenced and
5269 -- skip processing the argument.
5271 if Has_Pragma_Unreferenced
(Arg_Id
) then
5272 if Has_Pragma_Unused
(Arg_Id
) then
5274 (Fix_Error
("??pragma Unused already given for &!"),
5279 ("??pragma Unreferenced already given for &!"),
5283 -- Apply Unreferenced to the entity
5286 -- If the entity is overloaded, the pragma applies to the
5287 -- most recent overloading, as documented. In this case,
5288 -- name resolution does not generate a reference, so it
5289 -- must be done here explicitly.
5291 if Is_Overloaded
(Arg_Expr
) then
5292 Generate_Reference
(Arg_Id
, N
);
5295 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5298 Set_Has_Pragma_Unused
(Arg_Id
);
5301 -- A pragma that applies to a Ghost entity becomes Ghost
5302 -- for the purposes of legality checks and removal of
5303 -- ignored Ghost code.
5305 Mark_Ghost_Pragma
(N
, Arg_Id
);
5307 -- Capture the entity of the first Ghost name being
5308 -- processed for error detection purposes.
5310 if Is_Ghost_Entity
(Arg_Id
) then
5311 if No
(Ghost_Id
) then
5315 -- Otherwise the name is non-Ghost. It is illegal to mix
5316 -- references to Ghost and non-Ghost entities
5319 elsif Present
(Ghost_Id
)
5320 and then not Ghost_Error_Posted
5322 Ghost_Error_Posted
:= True;
5324 Error_Msg_Name_1
:= Pname
;
5326 ("pragma % cannot mention ghost and non-ghost "
5329 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5331 ("\& # declared as ghost", N
, Ghost_Id
);
5333 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5335 ("\& # declared as non-ghost", N
, Arg_Id
);
5343 end Analyze_Unreferenced_Or_Unused
;
5345 --------------------------
5346 -- Check_Ada_83_Warning --
5347 --------------------------
5349 procedure Check_Ada_83_Warning
is
5351 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5352 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5354 end Check_Ada_83_Warning
;
5356 ---------------------
5357 -- Check_Arg_Count --
5358 ---------------------
5360 procedure Check_Arg_Count
(Required
: Nat
) is
5362 if Arg_Count
/= Required
then
5363 Error_Pragma
("wrong number of arguments for pragma%");
5365 end Check_Arg_Count
;
5367 --------------------------------
5368 -- Check_Arg_Is_External_Name --
5369 --------------------------------
5371 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5372 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5375 if Nkind
(Argx
) = N_Identifier
then
5379 Analyze_And_Resolve
(Argx
, Standard_String
);
5381 if Is_OK_Static_Expression
(Argx
) then
5384 elsif Etype
(Argx
) = Any_Type
then
5387 -- An interesting special case, if we have a string literal and
5388 -- we are in Ada 83 mode, then we allow it even though it will
5389 -- not be flagged as static. This allows expected Ada 83 mode
5390 -- use of external names which are string literals, even though
5391 -- technically these are not static in Ada 83.
5393 elsif Ada_Version
= Ada_83
5394 and then Nkind
(Argx
) = N_String_Literal
5398 -- Here we have a real error (non-static expression)
5401 Error_Msg_Name_1
:= Pname
;
5402 Flag_Non_Static_Expr
5403 (Fix_Error
("argument for pragma% must be a identifier or "
5404 & "static string expression!"), Argx
);
5409 end Check_Arg_Is_External_Name
;
5411 -----------------------------
5412 -- Check_Arg_Is_Identifier --
5413 -----------------------------
5415 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5416 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5418 if Nkind
(Argx
) /= N_Identifier
then
5419 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5421 end Check_Arg_Is_Identifier
;
5423 ----------------------------------
5424 -- Check_Arg_Is_Integer_Literal --
5425 ----------------------------------
5427 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5428 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5430 if Nkind
(Argx
) /= N_Integer_Literal
then
5432 ("argument for pragma% must be integer literal", Argx
);
5434 end Check_Arg_Is_Integer_Literal
;
5436 -------------------------------------------
5437 -- Check_Arg_Is_Library_Level_Local_Name --
5438 -------------------------------------------
5442 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5443 -- | library_unit_NAME
5445 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5447 Check_Arg_Is_Local_Name
(Arg
);
5449 -- If it came from an aspect, we want to give the error just as if it
5450 -- came from source.
5452 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5453 and then (Comes_From_Source
(N
)
5454 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5457 ("argument for pragma% must be library level entity", Arg
);
5459 end Check_Arg_Is_Library_Level_Local_Name
;
5461 -----------------------------
5462 -- Check_Arg_Is_Local_Name --
5463 -----------------------------
5467 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5468 -- | library_unit_NAME
5470 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5471 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5474 -- If this pragma came from an aspect specification, we don't want to
5475 -- check for this error, because that would cause spurious errors, in
5476 -- case a type is frozen in a scope more nested than the type. The
5477 -- aspect itself of course can't be anywhere but on the declaration
5480 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5481 if From_Aspect_Specification
(Parent
(Arg
)) then
5485 -- Arg is the Expression of an N_Pragma_Argument_Association
5488 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5495 if Nkind
(Argx
) not in N_Direct_Name
5496 and then (Nkind
(Argx
) /= N_Attribute_Reference
5497 or else Present
(Expressions
(Argx
))
5498 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5499 and then (not Is_Entity_Name
(Argx
)
5500 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5502 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5505 -- No further check required if not an entity name
5507 if not Is_Entity_Name
(Argx
) then
5513 Ent
: constant Entity_Id
:= Entity
(Argx
);
5514 Scop
: constant Entity_Id
:= Scope
(Ent
);
5517 -- Case of a pragma applied to a compilation unit: pragma must
5518 -- occur immediately after the program unit in the compilation.
5520 if Is_Compilation_Unit
(Ent
) then
5522 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5525 -- Case of pragma placed immediately after spec
5527 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5530 -- Case of pragma placed immediately after body
5532 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5533 and then Present
(Corresponding_Body
(Decl
))
5537 (Parent
(Unit_Declaration_Node
5538 (Corresponding_Body
(Decl
))));
5540 -- All other cases are illegal
5547 -- Special restricted placement rule from 10.2.1(11.8/2)
5549 elsif Is_Generic_Formal
(Ent
)
5550 and then Prag_Id
= Pragma_Preelaborable_Initialization
5552 OK
:= List_Containing
(N
) =
5553 Generic_Formal_Declarations
5554 (Unit_Declaration_Node
(Scop
));
5556 -- If this is an aspect applied to a subprogram body, the
5557 -- pragma is inserted in its declarative part.
5559 elsif From_Aspect_Specification
(N
)
5560 and then Ent
= Current_Scope
5562 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5566 -- If the aspect is a predicate (possibly others ???) and the
5567 -- context is a record type, this is a discriminant expression
5568 -- within a type declaration, that freezes the predicated
5571 elsif From_Aspect_Specification
(N
)
5572 and then Prag_Id
= Pragma_Predicate
5573 and then Ekind
(Current_Scope
) = E_Record_Type
5574 and then Scop
= Scope
(Current_Scope
)
5578 -- Special case for postconditions wrappers
5580 elsif Ekind
(Scop
) in Subprogram_Kind
5581 and then Present
(Wrapped_Statements
(Scop
))
5582 and then Wrapped_Statements
(Scop
) = Current_Scope
5586 -- Default case, just check that the pragma occurs in the scope
5587 -- of the entity denoted by the name.
5590 OK
:= Current_Scope
= Scop
;
5595 ("pragma% argument must be in same declarative part", Arg
);
5599 end Check_Arg_Is_Local_Name
;
5601 ---------------------------------
5602 -- Check_Arg_Is_Locking_Policy --
5603 ---------------------------------
5605 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5606 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5609 Check_Arg_Is_Identifier
(Argx
);
5611 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5612 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5614 end Check_Arg_Is_Locking_Policy
;
5616 -----------------------------------------------
5617 -- Check_Arg_Is_Partition_Elaboration_Policy --
5618 -----------------------------------------------
5620 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5621 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5624 Check_Arg_Is_Identifier
(Argx
);
5626 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5628 ("& is not a valid partition elaboration policy name", Argx
);
5630 end Check_Arg_Is_Partition_Elaboration_Policy
;
5632 -------------------------
5633 -- Check_Arg_Is_One_Of --
5634 -------------------------
5636 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5637 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5640 Check_Arg_Is_Identifier
(Argx
);
5642 if Chars
(Argx
) not in N1 | N2
then
5643 Error_Msg_Name_2
:= N1
;
5644 Error_Msg_Name_3
:= N2
;
5645 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5647 end Check_Arg_Is_One_Of
;
5649 procedure Check_Arg_Is_One_Of
5651 N1
, N2
, N3
: Name_Id
)
5653 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5656 Check_Arg_Is_Identifier
(Argx
);
5658 if Chars
(Argx
) not in N1 | N2 | N3
then
5659 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5661 end Check_Arg_Is_One_Of
;
5663 procedure Check_Arg_Is_One_Of
5665 N1
, N2
, N3
, N4
: Name_Id
)
5667 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5670 Check_Arg_Is_Identifier
(Argx
);
5672 if Chars
(Argx
) not in N1 | N2 | N3 | N4
then
5673 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5675 end Check_Arg_Is_One_Of
;
5677 procedure Check_Arg_Is_One_Of
5679 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5681 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5684 Check_Arg_Is_Identifier
(Argx
);
5686 if Chars
(Argx
) not in N1 | N2 | N3 | N4 | N5
then
5687 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5689 end Check_Arg_Is_One_Of
;
5691 ---------------------------------
5692 -- Check_Arg_Is_Queuing_Policy --
5693 ---------------------------------
5695 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5696 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5699 Check_Arg_Is_Identifier
(Argx
);
5701 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5702 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5704 end Check_Arg_Is_Queuing_Policy
;
5706 ---------------------------------------
5707 -- Check_Arg_Is_OK_Static_Expression --
5708 ---------------------------------------
5710 procedure Check_Arg_Is_OK_Static_Expression
5712 Typ
: Entity_Id
:= Empty
)
5715 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5716 end Check_Arg_Is_OK_Static_Expression
;
5718 ------------------------------------------
5719 -- Check_Arg_Is_Task_Dispatching_Policy --
5720 ------------------------------------------
5722 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5723 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5726 Check_Arg_Is_Identifier
(Argx
);
5728 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5730 ("& is not an allowed task dispatching policy name", Argx
);
5732 end Check_Arg_Is_Task_Dispatching_Policy
;
5734 ---------------------
5735 -- Check_Arg_Order --
5736 ---------------------
5738 procedure Check_Arg_Order
(Names
: Name_List
) is
5741 Highest_So_Far
: Natural := 0;
5742 -- Highest index in Names seen do far
5746 for J
in 1 .. Arg_Count
loop
5747 if Chars
(Arg
) /= No_Name
then
5748 for K
in Names
'Range loop
5749 if Chars
(Arg
) = Names
(K
) then
5750 if K
< Highest_So_Far
then
5751 Error_Msg_Name_1
:= Pname
;
5753 ("parameters out of order for pragma%", Arg
);
5754 Error_Msg_Name_1
:= Names
(K
);
5755 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5756 Error_Msg_N
("\% must appear before %", Arg
);
5760 Highest_So_Far
:= K
;
5768 end Check_Arg_Order
;
5770 --------------------------------
5771 -- Check_At_Least_N_Arguments --
5772 --------------------------------
5774 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5776 if Arg_Count
< N
then
5777 Error_Pragma
("too few arguments for pragma%");
5779 end Check_At_Least_N_Arguments
;
5781 -------------------------------
5782 -- Check_At_Most_N_Arguments --
5783 -------------------------------
5785 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5788 if Arg_Count
> N
then
5790 for J
in 1 .. N
loop
5792 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5795 end Check_At_Most_N_Arguments
;
5797 ---------------------
5798 -- Check_Component --
5799 ---------------------
5801 procedure Check_Component
5804 In_Variant_Part
: Boolean := False)
5806 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5807 Sindic
: constant Node_Id
:=
5808 Subtype_Indication
(Component_Definition
(Comp
));
5809 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5812 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5813 -- object constraint, then the component type shall be an Unchecked_
5816 if Nkind
(Sindic
) = N_Subtype_Indication
5817 and then Has_Per_Object_Constraint
(Comp_Id
)
5818 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5821 ("component subtype subject to per-object constraint "
5822 & "must be an Unchecked_Union", Comp
);
5824 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5825 -- the body of a generic unit, or within the body of any of its
5826 -- descendant library units, no part of the type of a component
5827 -- declared in a variant_part of the unchecked union type shall be of
5828 -- a formal private type or formal private extension declared within
5829 -- the formal part of the generic unit.
5831 elsif Ada_Version
>= Ada_2012
5832 and then In_Generic_Body
(UU_Typ
)
5833 and then In_Variant_Part
5834 and then Is_Private_Type
(Typ
)
5835 and then Is_Generic_Type
(Typ
)
5838 ("component of unchecked union cannot be of generic type", Comp
);
5840 elsif Needs_Finalization
(Typ
) then
5842 ("component of unchecked union cannot be controlled", Comp
);
5844 elsif Has_Task
(Typ
) then
5846 ("component of unchecked union cannot have tasks", Comp
);
5848 end Check_Component
;
5850 ----------------------------
5851 -- Check_Duplicate_Pragma --
5852 ----------------------------
5854 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5855 Id
: Entity_Id
:= E
;
5859 -- Nothing to do if this pragma comes from an aspect specification,
5860 -- since we could not be duplicating a pragma, and we dealt with the
5861 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5863 if From_Aspect_Specification
(N
) then
5867 -- Otherwise current pragma may duplicate previous pragma or a
5868 -- previously given aspect specification or attribute definition
5869 -- clause for the same pragma.
5871 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5875 -- If the entity is a type, then we have to make sure that the
5876 -- ostensible duplicate is not for a parent type from which this
5880 if Nkind
(P
) = N_Pragma
then
5882 Args
: constant List_Id
:=
5883 Pragma_Argument_Associations
(P
);
5886 and then Is_Entity_Name
(Expression
(First
(Args
)))
5887 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5888 and then Entity
(Expression
(First
(Args
))) /= E
5894 elsif Nkind
(P
) = N_Aspect_Specification
5895 and then Is_Type
(Entity
(P
))
5896 and then Entity
(P
) /= E
5902 -- Here we have a definite duplicate
5904 Error_Msg_Name_1
:= Pragma_Name
(N
);
5905 Error_Msg_Sloc
:= Sloc
(P
);
5907 -- For a single protected or a single task object, the error is
5908 -- issued on the original entity.
5910 if Ekind
(Id
) in E_Task_Type | E_Protected_Type
then
5911 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5914 if Nkind
(P
) = N_Aspect_Specification
5915 or else From_Aspect_Specification
(P
)
5917 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5919 -- If -gnatwr is set, warn in case of a duplicate pragma
5920 -- [No_]Inline which is suspicious but not an error, generate
5921 -- an error for other pragmas.
5923 if Pragma_Name
(N
) in Name_Inline | Name_No_Inline
then
5924 if Warn_On_Redundant_Constructs
then
5926 ("?r?pragma% for & duplicates pragma#", N
, Id
);
5929 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5935 end Check_Duplicate_Pragma
;
5937 ----------------------------------
5938 -- Check_Duplicated_Export_Name --
5939 ----------------------------------
5941 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5942 String_Val
: constant String_Id
:= Strval
(Nam
);
5945 -- We are only interested in the export case, and in the case of
5946 -- generics, it is the instance, not the template, that is the
5947 -- problem (the template will generate a warning in any case).
5949 if not Inside_A_Generic
5950 and then (Prag_Id
= Pragma_Export
5952 Prag_Id
= Pragma_Export_Procedure
5954 Prag_Id
= Pragma_Export_Valued_Procedure
5956 Prag_Id
= Pragma_Export_Function
)
5958 for J
in Externals
.First
.. Externals
.Last
loop
5959 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5960 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5961 Error_Msg_N
("external name duplicates name given#", Nam
);
5966 Externals
.Append
(Nam
);
5968 end Check_Duplicated_Export_Name
;
5970 ----------------------------------------
5971 -- Check_Expr_Is_OK_Static_Expression --
5972 ----------------------------------------
5974 procedure Check_Expr_Is_OK_Static_Expression
5976 Typ
: Entity_Id
:= Empty
)
5979 if Present
(Typ
) then
5980 Analyze_And_Resolve
(Expr
, Typ
);
5982 Analyze_And_Resolve
(Expr
);
5985 -- An expression cannot be considered static if its resolution failed
5986 -- or if it's erroneous. Stop the analysis of the related pragma.
5988 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5991 elsif Is_OK_Static_Expression
(Expr
) then
5994 -- An interesting special case, if we have a string literal and we
5995 -- are in Ada 83 mode, then we allow it even though it will not be
5996 -- flagged as static. This allows the use of Ada 95 pragmas like
5997 -- Import in Ada 83 mode. They will of course be flagged with
5998 -- warnings as usual, but will not cause errors.
6000 elsif Ada_Version
= Ada_83
6001 and then Nkind
(Expr
) = N_String_Literal
6005 -- Finally, we have a real error
6008 Error_Msg_Name_1
:= Pname
;
6009 Flag_Non_Static_Expr
6010 (Fix_Error
("argument for pragma% must be a static expression!"),
6014 end Check_Expr_Is_OK_Static_Expression
;
6016 -------------------------
6017 -- Check_First_Subtype --
6018 -------------------------
6020 procedure Check_First_Subtype
(Arg
: Node_Id
) is
6021 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6022 Ent
: constant Entity_Id
:= Entity
(Argx
);
6025 if Is_First_Subtype
(Ent
) then
6028 elsif Is_Type
(Ent
) then
6030 ("pragma% cannot apply to subtype", Argx
);
6032 elsif Is_Object
(Ent
) then
6034 ("pragma% cannot apply to object, requires a type", Argx
);
6038 ("pragma% cannot apply to&, requires a type", Argx
);
6040 end Check_First_Subtype
;
6042 ----------------------
6043 -- Check_Identifier --
6044 ----------------------
6046 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6049 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6051 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
6052 Error_Msg_Name_1
:= Pname
;
6053 Error_Msg_Name_2
:= Id
;
6054 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6058 end Check_Identifier
;
6060 --------------------------------
6061 -- Check_Identifier_Is_One_Of --
6062 --------------------------------
6064 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
6067 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6069 if Chars
(Arg
) = No_Name
then
6070 Error_Msg_Name_1
:= Pname
;
6071 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
6074 elsif Chars
(Arg
) /= N1
6075 and then Chars
(Arg
) /= N2
6077 Error_Msg_Name_1
:= Pname
;
6078 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
6082 end Check_Identifier_Is_One_Of
;
6084 ---------------------------
6085 -- Check_In_Main_Program --
6086 ---------------------------
6088 procedure Check_In_Main_Program
is
6089 P
: constant Node_Id
:= Parent
(N
);
6092 -- Must be in subprogram body
6094 if Nkind
(P
) /= N_Subprogram_Body
then
6095 Error_Pragma
("% pragma allowed only in subprogram");
6097 -- Otherwise warn if obviously not main program
6099 elsif Present
(Parameter_Specifications
(Specification
(P
)))
6100 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
6102 Error_Msg_Name_1
:= Pname
;
6104 ("??pragma% is only effective in main program", N
);
6106 end Check_In_Main_Program
;
6108 ---------------------------------------
6109 -- Check_Interrupt_Or_Attach_Handler --
6110 ---------------------------------------
6112 procedure Check_Interrupt_Or_Attach_Handler
is
6113 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6114 Handler_Proc
, Proc_Scope
: Entity_Id
;
6119 if Prag_Id
= Pragma_Interrupt_Handler
then
6120 Check_Restriction
(No_Dynamic_Attachment
, N
);
6123 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
6124 Proc_Scope
:= Scope
(Handler_Proc
);
6126 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
6128 ("argument of pragma% must be protected procedure", Arg1
);
6131 -- For pragma case (as opposed to access case), check placement.
6132 -- We don't need to do that for aspects, because we have the
6133 -- check that they aspect applies an appropriate procedure.
6135 if not From_Aspect_Specification
(N
)
6136 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
6138 Error_Pragma
("pragma% must be in protected definition");
6141 if not Is_Library_Level_Entity
(Proc_Scope
) then
6143 ("argument for pragma% must be library level entity", Arg1
);
6146 -- AI05-0033: A pragma cannot appear within a generic body, because
6147 -- instance can be in a nested scope. The check that protected type
6148 -- is itself a library-level declaration is done elsewhere.
6150 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6151 -- handle code prior to AI-0033. Analysis tools typically are not
6152 -- interested in this pragma in any case, so no need to worry too
6153 -- much about its placement.
6155 if Inside_A_Generic
then
6156 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
6157 and then In_Package_Body
(Scope
(Current_Scope
))
6158 and then not Relaxed_RM_Semantics
6160 Error_Pragma
("pragma% cannot be used inside a generic");
6163 end Check_Interrupt_Or_Attach_Handler
;
6165 ---------------------------------
6166 -- Check_Loop_Pragma_Placement --
6167 ---------------------------------
6169 procedure Check_Loop_Pragma_Placement
is
6170 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
6171 -- Verify whether the current pragma is properly grouped with other
6172 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6173 -- related loop where the pragma appears.
6175 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
6176 -- Determine whether an arbitrary statement Stmt denotes pragma
6177 -- Loop_Invariant or Loop_Variant.
6179 procedure Placement_Error
(Constr
: Node_Id
);
6180 pragma No_Return
(Placement_Error
);
6181 -- Node Constr denotes the last loop restricted construct before we
6182 -- encountered an illegal relation between enclosing constructs. Emit
6183 -- an error depending on what Constr was.
6185 --------------------------------
6186 -- Check_Loop_Pragma_Grouping --
6187 --------------------------------
6189 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6190 function Check_Grouping
(L
: List_Id
) return Boolean;
6191 -- Find the first group of pragmas in list L and if successful,
6192 -- ensure that the current pragma is part of that group. The
6193 -- routine returns True once such a check is performed to
6194 -- stop the analysis.
6196 procedure Grouping_Error
(Prag
: Node_Id
);
6197 pragma No_Return
(Grouping_Error
);
6198 -- Emit an error concerning the current pragma indicating that it
6199 -- should be placed after pragma Prag.
6201 --------------------
6202 -- Check_Grouping --
6203 --------------------
6205 function Check_Grouping
(L
: List_Id
) return Boolean is
6208 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6211 -- Inspect the list of declarations or statements looking for
6212 -- the first grouping of pragmas:
6215 -- pragma Loop_Invariant ...;
6216 -- pragma Loop_Variant ...;
6218 -- pragma Loop_Variant ...; -- current pragma
6220 -- If the current pragma is not in the grouping, then it must
6221 -- either appear in a different declarative or statement list
6222 -- or the construct at (1) is separating the pragma from the
6226 while Present
(Stmt
) loop
6228 -- First pragma of the first topmost grouping has been found
6230 if Is_Loop_Pragma
(Stmt
) then
6232 -- The group and the current pragma are not in the same
6233 -- declarative or statement list.
6235 if not In_Same_List
(Stmt
, N
) then
6236 Grouping_Error
(Stmt
);
6238 -- Try to reach the current pragma from the first pragma
6239 -- of the grouping while skipping other members:
6241 -- pragma Loop_Invariant ...; -- first pragma
6242 -- pragma Loop_Variant ...; -- member
6244 -- pragma Loop_Variant ...; -- current pragma
6247 while Present
(Stmt
) loop
6248 -- The current pragma is either the first pragma
6249 -- of the group or is a member of the group.
6250 -- Stop the search as the placement is legal.
6255 -- Skip group members, but keep track of the
6256 -- last pragma in the group.
6258 elsif Is_Loop_Pragma
(Stmt
) then
6261 -- Skip declarations and statements generated by
6262 -- the compiler during expansion. Note that some
6263 -- source statements (e.g. pragma Assert) may have
6264 -- been transformed so that they do not appear as
6265 -- coming from source anymore, so we instead look
6266 -- at their Original_Node.
6268 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6272 -- A non-pragma is separating the group from the
6273 -- current pragma, the placement is illegal.
6276 Grouping_Error
(Prag
);
6282 -- If the traversal did not reach the current pragma,
6283 -- then the list must be malformed.
6285 raise Program_Error
;
6288 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6289 -- inside a loop or a block housed inside a loop. Inspect
6290 -- the declarations and statements of the block as they may
6291 -- contain the first grouping. This case follows the one for
6292 -- loop pragmas, as block statements which originate in a
6293 -- loop pragma (and so Is_Loop_Pragma will return True on
6294 -- that block statement) should be treated in the previous
6297 elsif Nkind
(Stmt
) = N_Block_Statement
then
6298 HSS
:= Handled_Statement_Sequence
(Stmt
);
6300 if Check_Grouping
(Declarations
(Stmt
)) then
6304 if Present
(HSS
) then
6305 if Check_Grouping
(Statements
(HSS
)) then
6317 --------------------
6318 -- Grouping_Error --
6319 --------------------
6321 procedure Grouping_Error
(Prag
: Node_Id
) is
6323 Error_Msg_Sloc
:= Sloc
(Prag
);
6324 Error_Pragma
("pragma% must appear next to pragma#");
6329 -- Start of processing for Check_Loop_Pragma_Grouping
6332 -- Inspect the statements of the loop or nested blocks housed
6333 -- within to determine whether the current pragma is part of the
6334 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6336 Ignore
:= Check_Grouping
(Statements
(Loop_Stmt
));
6337 end Check_Loop_Pragma_Grouping
;
6339 --------------------
6340 -- Is_Loop_Pragma --
6341 --------------------
6343 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6344 Original_Stmt
: constant Node_Id
:= Original_Node
(Stmt
);
6347 -- Inspect the original node as Loop_Invariant and Loop_Variant
6348 -- pragmas are rewritten to null when assertions are disabled.
6350 return Nkind
(Original_Stmt
) = N_Pragma
6351 and then Pragma_Name_Unmapped
(Original_Stmt
)
6352 in Name_Loop_Invariant | Name_Loop_Variant
;
6355 ---------------------
6356 -- Placement_Error --
6357 ---------------------
6359 procedure Placement_Error
(Constr
: Node_Id
) is
6360 LA
: constant String := " with Loop_Entry";
6363 if Prag_Id
= Pragma_Assert
then
6364 Error_Msg_String
(1 .. LA
'Length) := LA
;
6365 Error_Msg_Strlen
:= LA
'Length;
6367 Error_Msg_Strlen
:= 0;
6370 if Nkind
(Constr
) = N_Pragma
then
6372 ("pragma %~ must appear immediately within the statements "
6376 ("block containing pragma %~ must appear immediately within "
6377 & "the statements of a loop", Constr
);
6379 end Placement_Error
;
6381 -- Local declarations
6386 -- Start of processing for Check_Loop_Pragma_Placement
6389 -- Check that pragma appears immediately within a loop statement,
6390 -- ignoring intervening block statements.
6394 while Present
(Stmt
) loop
6396 -- The pragma or previous block must appear immediately within the
6397 -- current block's declarative or statement part.
6399 if Nkind
(Stmt
) = N_Block_Statement
then
6400 if (No
(Declarations
(Stmt
))
6401 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6403 List_Containing
(Prev
) /=
6404 Statements
(Handled_Statement_Sequence
(Stmt
))
6406 Placement_Error
(Prev
);
6408 -- Keep inspecting the parents because we are now within a
6409 -- chain of nested blocks.
6413 Stmt
:= Parent
(Stmt
);
6416 -- The pragma or previous block must appear immediately within the
6417 -- statements of the loop.
6419 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6420 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6421 Placement_Error
(Prev
);
6424 -- Stop the traversal because we reached the innermost loop
6425 -- regardless of whether we encountered an error or not.
6429 -- Ignore a handled statement sequence. Note that this node may
6430 -- be related to a subprogram body in which case we will emit an
6431 -- error on the next iteration of the search.
6433 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6434 Stmt
:= Parent
(Stmt
);
6436 -- Any other statement breaks the chain from the pragma to the
6440 Placement_Error
(Prev
);
6444 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6445 -- grouped together with other such pragmas.
6447 if Is_Loop_Pragma
(N
) then
6449 -- The previous check should have located the related loop
6451 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6452 Check_Loop_Pragma_Grouping
(Stmt
);
6454 end Check_Loop_Pragma_Placement
;
6456 -------------------------------------------
6457 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6458 -------------------------------------------
6460 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6469 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6472 elsif Nkind
(P
) in N_Package_Specification | N_Block_Statement
then
6475 -- Note: the following tests seem a little peculiar, because
6476 -- they test for bodies, but if we were in the statement part
6477 -- of the body, we would already have hit the handled statement
6478 -- sequence, so the only way we get here is by being in the
6479 -- declarative part of the body.
6482 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6490 Error_Pragma
("pragma% is not in declarative part or package spec");
6491 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6493 -------------------------
6494 -- Check_No_Identifier --
6495 -------------------------
6497 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6499 if Nkind
(Arg
) = N_Pragma_Argument_Association
6500 and then Chars
(Arg
) /= No_Name
6502 Error_Pragma_Arg_Ident
6503 ("pragma% does not permit identifier& here", Arg
);
6505 end Check_No_Identifier
;
6507 --------------------------
6508 -- Check_No_Identifiers --
6509 --------------------------
6511 procedure Check_No_Identifiers
is
6515 for J
in 1 .. Arg_Count
loop
6516 Check_No_Identifier
(Arg_Node
);
6519 end Check_No_Identifiers
;
6521 ------------------------
6522 -- Check_No_Link_Name --
6523 ------------------------
6525 procedure Check_No_Link_Name
is
6527 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6531 if Present
(Arg4
) then
6533 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6535 end Check_No_Link_Name
;
6537 -------------------------------
6538 -- Check_Optional_Identifier --
6539 -------------------------------
6541 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6544 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6545 and then Chars
(Arg
) /= No_Name
6547 if Chars
(Arg
) /= Id
then
6548 Error_Msg_Name_1
:= Pname
;
6549 Error_Msg_Name_2
:= Id
;
6550 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6554 end Check_Optional_Identifier
;
6556 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6558 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6559 end Check_Optional_Identifier
;
6561 -------------------------------------
6562 -- Check_Static_Boolean_Expression --
6563 -------------------------------------
6565 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6567 if Present
(Expr
) then
6568 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6570 if not Is_OK_Static_Expression
(Expr
) then
6572 ("expression of pragma % must be static", Expr
);
6575 end Check_Static_Boolean_Expression
;
6577 -----------------------------
6578 -- Check_Static_Constraint --
6579 -----------------------------
6581 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6583 procedure Require_Static
(E
: Node_Id
);
6584 -- Require given expression to be static expression
6586 --------------------
6587 -- Require_Static --
6588 --------------------
6590 procedure Require_Static
(E
: Node_Id
) is
6592 if not Is_OK_Static_Expression
(E
) then
6593 Flag_Non_Static_Expr
6594 ("non-static constraint not allowed in Unchecked_Union!", E
);
6599 -- Start of processing for Check_Static_Constraint
6602 case Nkind
(Constr
) is
6603 when N_Discriminant_Association
=>
6604 Require_Static
(Expression
(Constr
));
6607 Require_Static
(Low_Bound
(Constr
));
6608 Require_Static
(High_Bound
(Constr
));
6610 when N_Attribute_Reference
=>
6611 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6612 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6614 when N_Range_Constraint
=>
6615 Check_Static_Constraint
(Range_Expression
(Constr
));
6617 when N_Index_Or_Discriminant_Constraint
=>
6621 IDC
:= First
(Constraints
(Constr
));
6622 while Present
(IDC
) loop
6623 Check_Static_Constraint
(IDC
);
6631 end Check_Static_Constraint
;
6633 --------------------------------------
6634 -- Check_Valid_Configuration_Pragma --
6635 --------------------------------------
6637 -- A configuration pragma must appear in the context clause of a
6638 -- compilation unit, and only other pragmas may precede it. Note that
6639 -- the test also allows use in a configuration pragma file.
6641 procedure Check_Valid_Configuration_Pragma
is
6643 if not Is_Configuration_Pragma
then
6644 Error_Pragma
("incorrect placement for configuration pragma%");
6646 end Check_Valid_Configuration_Pragma
;
6648 -------------------------------------
6649 -- Check_Valid_Library_Unit_Pragma --
6650 -------------------------------------
6652 procedure Check_Valid_Library_Unit_Pragma
is
6654 Parent_Node
: Node_Id
;
6655 Unit_Name
: Entity_Id
;
6656 Unit_Kind
: Node_Kind
;
6657 Unit_Node
: Node_Id
;
6658 Sindex
: Source_File_Index
;
6661 if not Is_List_Member
(N
) then
6665 Plist
:= List_Containing
(N
);
6666 Parent_Node
:= Parent
(Plist
);
6668 if Parent_Node
= Empty
then
6671 -- Case of pragma appearing after a compilation unit. In this case
6672 -- it must have an argument with the corresponding name and must
6673 -- be part of the following pragmas of its parent.
6675 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6676 if Plist
/= Pragmas_After
(Parent_Node
) then
6678 ("pragma% misplaced, must be inside or after the "
6679 & "compilation unit");
6681 elsif Arg_Count
= 0 then
6683 ("argument required if outside compilation unit");
6686 Check_No_Identifiers
;
6687 Check_Arg_Count
(1);
6688 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6689 Unit_Kind
:= Nkind
(Unit_Node
);
6691 Analyze
(Get_Pragma_Arg
(Arg1
));
6693 if Unit_Kind
= N_Generic_Subprogram_Declaration
6694 or else Unit_Kind
= N_Subprogram_Declaration
6696 Unit_Name
:= Defining_Entity
(Unit_Node
);
6698 elsif Unit_Kind
in N_Generic_Instantiation
then
6699 Unit_Name
:= Defining_Entity
(Unit_Node
);
6702 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6705 if Chars
(Unit_Name
) /=
6706 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6709 ("pragma% argument is not current unit name", Arg1
);
6712 if Ekind
(Unit_Name
) = E_Package
6713 and then Present
(Renamed_Entity
(Unit_Name
))
6715 Error_Pragma
("pragma% not allowed for renamed package");
6719 -- Pragma appears other than after a compilation unit
6722 -- Here we check for the generic instantiation case and also
6723 -- for the case of processing a generic formal package. We
6724 -- detect these cases by noting that the Sloc on the node
6725 -- does not belong to the current compilation unit.
6727 Sindex
:= Source_Index
(Current_Sem_Unit
);
6729 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6730 -- We do not want to raise an exception here since this code
6731 -- is part of the bootstrap path where we cannot rely on
6732 -- exception propagation working.
6733 -- Instead the caller should check for N being rewritten as
6734 -- a null statement.
6735 -- This code triggers when compiling a-except.adb.
6737 Rewrite
(N
, Make_Null_Statement
(Loc
));
6739 -- If before first declaration, the pragma applies to the
6740 -- enclosing unit, and the name if present must be this name.
6742 elsif Is_Before_First_Decl
(N
, Plist
) then
6743 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6744 Unit_Kind
:= Nkind
(Unit_Node
);
6746 if Unit_Node
= Standard_Package_Node
then
6748 ("pragma% misplaced, must be inside or after the "
6749 & "compilation unit");
6751 elsif Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6753 ("pragma% misplaced, must be on library unit");
6755 elsif Unit_Kind
= N_Subprogram_Body
6756 and then not Acts_As_Spec
(Unit_Node
)
6759 ("pragma% misplaced, must be on the subprogram spec");
6761 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6763 ("pragma% misplaced, must be on the package spec");
6765 elsif Nkind
(Parent_Node
) = N_Package_Specification
6766 and then Plist
= Private_Declarations
(Parent_Node
)
6769 ("pragma% misplaced, must be in the public part");
6771 elsif Nkind
(Parent_Node
) in N_Generic_Declaration
6772 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6775 ("pragma% misplaced, must not be in formal part");
6777 elsif Arg_Count
> 0 then
6778 Analyze
(Get_Pragma_Arg
(Arg1
));
6780 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6782 ("name in pragma% must be enclosing unit", Arg1
);
6785 -- It is legal to have no argument in this context
6791 -- Error if not before first declaration. This is because a
6792 -- library unit pragma argument must be the name of a library
6793 -- unit (RM 10.1.5(7)), but the only names permitted in this
6794 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6795 -- generic subprogram declarations or generic instantiations.
6799 ("pragma% misplaced, must be before first declaration");
6803 end Check_Valid_Library_Unit_Pragma
;
6809 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6810 Clist
: constant Node_Id
:= Component_List
(Variant
);
6814 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6815 while Present
(Comp
) loop
6816 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6817 Next_Non_Pragma
(Comp
);
6821 ---------------------------
6822 -- Ensure_Aggregate_Form --
6823 ---------------------------
6825 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6826 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6827 Expr
: constant Node_Id
:= Expression
(Arg
);
6828 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6829 Comps
: List_Id
:= No_List
;
6830 Exprs
: List_Id
:= No_List
;
6831 Nam
: Name_Id
:= No_Name
;
6832 Nam_Loc
: Source_Ptr
;
6835 -- The pragma argument is in positional form:
6837 -- pragma Depends (Nam => ...)
6841 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6842 -- argument association.
6844 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6846 Nam_Loc
:= Sloc
(Arg
);
6848 -- Remove the pragma argument name as this will be captured in the
6851 Set_Chars
(Arg
, No_Name
);
6854 -- The argument is already in aggregate form, but the presence of a
6855 -- name causes this to be interpreted as named association which in
6856 -- turn must be converted into an aggregate.
6858 -- pragma Global (In_Out => (A, B, C))
6862 -- pragma Global ((In_Out => (A, B, C)))
6864 -- aggregate aggregate
6866 if Nkind
(Expr
) = N_Aggregate
then
6867 if Nam
= No_Name
then
6871 -- Do not transform a null argument into an aggregate as N_Null has
6872 -- special meaning in formal verification pragmas.
6874 elsif Nkind
(Expr
) = N_Null
then
6878 -- Everything comes from source if the original comes from source
6880 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6882 -- Positional argument is transformed into an aggregate with an
6883 -- Expressions list.
6885 if Nam
= No_Name
then
6886 Exprs
:= New_List
(Relocate_Node
(Expr
));
6888 -- An associative argument is transformed into an aggregate with
6889 -- Component_Associations.
6893 Make_Component_Association
(Loc
,
6894 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6895 Expression
=> Relocate_Node
(Expr
)));
6898 Set_Expression
(Arg
,
6899 Make_Aggregate
(Loc
,
6900 Component_Associations
=> Comps
,
6901 Expressions
=> Exprs
));
6903 -- Restore Comes_From_Source default
6905 Set_Comes_From_Source_Default
(CFSD
);
6906 end Ensure_Aggregate_Form
;
6912 procedure Error_Pragma
(Msg
: String) is
6914 Error_Msg_Name_1
:= Pname
;
6915 Error_Msg_N
(Fix_Error
(Msg
), N
);
6919 ----------------------
6920 -- Error_Pragma_Arg --
6921 ----------------------
6923 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6925 Error_Msg_Name_1
:= Pname
;
6926 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6928 end Error_Pragma_Arg
;
6930 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6932 Error_Msg_Name_1
:= Pname
;
6933 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6934 Error_Pragma_Arg
(Msg2
, Arg
);
6935 end Error_Pragma_Arg
;
6937 ----------------------------
6938 -- Error_Pragma_Arg_Ident --
6939 ----------------------------
6941 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6943 Error_Msg_Name_1
:= Pname
;
6944 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6946 end Error_Pragma_Arg_Ident
;
6948 ----------------------
6949 -- Error_Pragma_Ref --
6950 ----------------------
6952 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6954 Error_Msg_Name_1
:= Pname
;
6955 Error_Msg_Sloc
:= Sloc
(Ref
);
6956 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6958 end Error_Pragma_Ref
;
6960 ------------------------
6961 -- Find_Lib_Unit_Name --
6962 ------------------------
6964 function Find_Lib_Unit_Name
return Entity_Id
is
6966 -- Return inner compilation unit entity, for case of nested
6967 -- categorization pragmas. This happens in generic unit.
6969 if Nkind
(Parent
(N
)) = N_Package_Specification
6970 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6972 return Defining_Entity
(Parent
(N
));
6974 return Current_Scope
;
6976 end Find_Lib_Unit_Name
;
6978 ----------------------------
6979 -- Find_Program_Unit_Name --
6980 ----------------------------
6982 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6983 Unit_Name
: Entity_Id
;
6984 Unit_Kind
: Node_Kind
;
6985 P
: constant Node_Id
:= Parent
(N
);
6988 if Nkind
(P
) = N_Compilation_Unit
then
6989 Unit_Kind
:= Nkind
(Unit
(P
));
6991 if Unit_Kind
in N_Subprogram_Declaration
6992 | N_Package_Declaration
6993 | N_Generic_Declaration
6995 Unit_Name
:= Defining_Entity
(Unit
(P
));
6997 if Chars
(Id
) = Chars
(Unit_Name
) then
6998 Set_Entity
(Id
, Unit_Name
);
6999 Set_Etype
(Id
, Etype
(Unit_Name
));
7001 Set_Etype
(Id
, Any_Type
);
7003 ("cannot find program unit referenced by pragma%");
7007 Set_Etype
(Id
, Any_Type
);
7008 Error_Pragma
("pragma% inapplicable to this unit");
7014 end Find_Program_Unit_Name
;
7016 -----------------------------------------
7017 -- Find_Unique_Parameterless_Procedure --
7018 -----------------------------------------
7020 function Find_Unique_Parameterless_Procedure
7022 Arg
: Node_Id
) return Entity_Id
7024 Proc
: Entity_Id
:= Empty
;
7027 -- Perform sanity checks on Name
7029 if not Is_Entity_Name
(Name
) then
7031 ("argument of pragma% must be entity name", Arg
);
7033 elsif not Is_Overloaded
(Name
) then
7034 Proc
:= Entity
(Name
);
7036 if Ekind
(Proc
) /= E_Procedure
7037 or else Present
(First_Formal
(Proc
))
7040 ("argument of pragma% must be parameterless procedure", Arg
);
7043 -- Otherwise, search through interpretations looking for one which
7044 -- has no parameters.
7048 Found
: Boolean := False;
7050 Index
: Interp_Index
;
7053 Get_First_Interp
(Name
, Index
, It
);
7054 while Present
(It
.Nam
) loop
7057 if Ekind
(Proc
) = E_Procedure
7058 and then No
(First_Formal
(Proc
))
7060 -- We found an interpretation, note it and continue
7061 -- looking looking to verify it is unique.
7065 Set_Entity
(Name
, Proc
);
7066 Set_Is_Overloaded
(Name
, False);
7068 -- Two procedures with the same name, log an error
7069 -- since the name is ambiguous.
7073 ("ambiguous handler name for pragma%", Arg
);
7077 Get_Next_Interp
(Index
, It
);
7081 -- Issue an error if we haven't found a suitable match for
7085 ("argument of pragma% must be parameterless procedure",
7089 Proc
:= Entity
(Name
);
7095 end Find_Unique_Parameterless_Procedure
;
7101 function Fix_Error
(Msg
: String) return String is
7102 Res
: String (Msg
'Range) := Msg
;
7103 Res_Last
: Natural := Msg
'Last;
7107 -- If we have a rewriting of another pragma, go to that pragma
7109 if Is_Rewrite_Substitution
(N
)
7110 and then Nkind
(Original_Node
(N
)) = N_Pragma
7112 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
7115 -- Case where pragma comes from an aspect specification
7117 if From_Aspect_Specification
(N
) then
7119 -- Change appearance of "pragma" in message to "aspect"
7122 while J
<= Res_Last
- 5 loop
7123 if Res
(J
.. J
+ 5) = "pragma" then
7124 Res
(J
.. J
+ 5) := "aspect";
7132 -- Change "argument of" at start of message to "entity for"
7135 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
7137 Res
(Res
'First .. Res
'First + 9) := "entity for";
7138 Res
(Res
'First + 10 .. Res_Last
- 1) :=
7139 Res
(Res
'First + 11 .. Res_Last
);
7140 Res_Last
:= Res_Last
- 1;
7143 -- Change "argument" at start of message to "entity"
7146 and then Res
(Res
'First .. Res
'First + 7) = "argument"
7148 Res
(Res
'First .. Res
'First + 5) := "entity";
7149 Res
(Res
'First + 6 .. Res_Last
- 2) :=
7150 Res
(Res
'First + 8 .. Res_Last
);
7151 Res_Last
:= Res_Last
- 2;
7154 -- Get name from corresponding aspect
7156 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
7159 -- Return possibly modified message
7161 return Res
(Res
'First .. Res_Last
);
7164 -------------------------
7165 -- Gather_Associations --
7166 -------------------------
7168 procedure Gather_Associations
7170 Args
: out Args_List
)
7175 -- Initialize all parameters to Empty
7177 for J
in Args
'Range loop
7181 -- That's all we have to do if there are no argument associations
7183 if No
(Pragma_Argument_Associations
(N
)) then
7187 -- Otherwise first deal with any positional parameters present
7189 Arg
:= First
(Pragma_Argument_Associations
(N
));
7190 for Index
in Args
'Range loop
7191 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
7192 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7196 -- Positional parameters all processed, if any left, then we
7197 -- have too many positional parameters.
7199 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
7201 ("too many positional associations for pragma%", Arg
);
7204 -- Process named parameters if any are present
7206 while Present
(Arg
) loop
7207 if Chars
(Arg
) = No_Name
then
7209 ("positional association cannot follow named association",
7213 for Index
in Names
'Range loop
7214 if Names
(Index
) = Chars
(Arg
) then
7215 if Present
(Args
(Index
)) then
7217 ("duplicate argument association for pragma%", Arg
);
7219 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7224 if Index
= Names
'Last then
7225 Error_Msg_Name_1
:= Pname
;
7226 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7228 -- Check for possible misspelling
7230 for Index1
in Names
'Range loop
7231 if Is_Bad_Spelling_Of
7232 (Chars
(Arg
), Names
(Index1
))
7234 Error_Msg_Name_1
:= Names
(Index1
);
7235 Error_Msg_N
-- CODEFIX
7236 ("\possible misspelling of%", Arg
);
7248 end Gather_Associations
;
7254 procedure GNAT_Pragma
is
7256 -- We need to check the No_Implementation_Pragmas restriction for
7257 -- the case of a pragma from source. Note that the case of aspects
7258 -- generating corresponding pragmas marks these pragmas as not being
7259 -- from source, so this test also catches that case.
7261 if Comes_From_Source
(N
) then
7262 Check_Restriction
(No_Implementation_Pragmas
, N
);
7266 --------------------------
7267 -- Is_Before_First_Decl --
7268 --------------------------
7270 function Is_Before_First_Decl
7271 (Pragma_Node
: Node_Id
;
7272 Decls
: List_Id
) return Boolean
7274 Item
: Node_Id
:= First
(Decls
);
7277 -- Only other pragmas can come before this pragma, but they might
7278 -- have been rewritten so check the original node.
7281 if No
(Item
) or else Nkind
(Original_Node
(Item
)) /= N_Pragma
then
7284 elsif Item
= Pragma_Node
then
7290 end Is_Before_First_Decl
;
7292 -----------------------------
7293 -- Is_Configuration_Pragma --
7294 -----------------------------
7296 -- A configuration pragma must appear in the context clause of a
7297 -- compilation unit, and only other pragmas may precede it. Note that
7298 -- the test below also permits use in a configuration pragma file.
7300 function Is_Configuration_Pragma
return Boolean is
7302 Par
: constant Node_Id
:= Parent
(N
);
7306 -- Don't evaluate List_Containing (N) if Parent (N) could be
7307 -- an N_Aspect_Specification node.
7309 if not Is_List_Member
(N
) then
7313 Lis
:= List_Containing
(N
);
7315 -- If no parent, then we are in the configuration pragma file,
7316 -- so the placement is definitely appropriate.
7321 -- Otherwise we must be in the context clause of a compilation unit
7322 -- and the only thing allowed before us in the context list is more
7323 -- configuration pragmas.
7325 elsif Nkind
(Par
) = N_Compilation_Unit
7326 and then Context_Items
(Par
) = Lis
7333 elsif Nkind
(Prg
) /= N_Pragma
then
7343 end Is_Configuration_Pragma
;
7345 --------------------------
7346 -- Is_In_Context_Clause --
7347 --------------------------
7349 function Is_In_Context_Clause
return Boolean is
7351 Parent_Node
: Node_Id
;
7354 if Is_List_Member
(N
) then
7355 Plist
:= List_Containing
(N
);
7356 Parent_Node
:= Parent
(Plist
);
7358 return Present
(Parent_Node
)
7359 and then Nkind
(Parent_Node
) = N_Compilation_Unit
7360 and then Context_Items
(Parent_Node
) = Plist
;
7364 end Is_In_Context_Clause
;
7366 ---------------------------------
7367 -- Is_Static_String_Expression --
7368 ---------------------------------
7370 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7371 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7372 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7375 Analyze_And_Resolve
(Argx
);
7377 -- Special case Ada 83, where the expression will never be static,
7378 -- but we will return true if we had a string literal to start with.
7380 if Ada_Version
= Ada_83
then
7383 -- Normal case, true only if we end up with a string literal that
7384 -- is marked as being the result of evaluating a static expression.
7387 return Is_OK_Static_Expression
(Argx
)
7388 and then Nkind
(Argx
) = N_String_Literal
;
7391 end Is_Static_String_Expression
;
7393 ----------------------
7394 -- Pragma_Misplaced --
7395 ----------------------
7397 procedure Pragma_Misplaced
is
7399 Error_Pragma
("incorrect placement of pragma%");
7400 end Pragma_Misplaced
;
7402 ------------------------------------------------
7403 -- Process_Atomic_Independent_Shared_Volatile --
7404 ------------------------------------------------
7406 procedure Process_Atomic_Independent_Shared_Volatile
is
7407 procedure Check_Full_Access_Only
(Ent
: Entity_Id
);
7408 -- Apply legality checks to type or object Ent subject to the
7409 -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
7411 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7412 -- Appropriately set flags on the given entity, either an array or
7413 -- record component, or an object declaration) according to the
7416 procedure Mark_Type
(Ent
: Entity_Id
);
7417 -- Appropriately set flags on the given entity, a type
7419 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7420 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7421 -- no explicit alignment was given, set alignment to unknown, since
7422 -- back end knows what the alignment requirements are for atomic and
7423 -- full access arrays. Note: this is necessary for derived types.
7425 -------------------------
7426 -- Check_Full_Access_Only --
7427 -------------------------
7429 procedure Check_Full_Access_Only
(Ent
: Entity_Id
) is
7432 Full_Access_Subcomponent
: exception;
7433 -- Exception raised if a full access subcomponent is found
7435 Generic_Type_Subcomponent
: exception;
7436 -- Exception raised if a subcomponent with generic type is found
7438 procedure Check_Subcomponents
(Typ
: Entity_Id
);
7439 -- Apply checks to subcomponents recursively
7441 -------------------------
7442 -- Check_Subcomponents --
7443 -------------------------
7445 procedure Check_Subcomponents
(Typ
: Entity_Id
) is
7449 if Is_Array_Type
(Typ
) then
7450 Comp
:= Component_Type
(Typ
);
7452 if Has_Atomic_Components
(Typ
)
7453 or else Is_Full_Access
(Comp
)
7455 raise Full_Access_Subcomponent
;
7457 elsif Is_Generic_Type
(Comp
) then
7458 raise Generic_Type_Subcomponent
;
7461 -- Recurse on the component type
7463 Check_Subcomponents
(Comp
);
7465 elsif Is_Record_Type
(Typ
) then
7466 Comp
:= First_Component_Or_Discriminant
(Typ
);
7467 while Present
(Comp
) loop
7469 if Is_Full_Access
(Comp
)
7470 or else Is_Full_Access
(Etype
(Comp
))
7472 raise Full_Access_Subcomponent
;
7474 elsif Is_Generic_Type
(Etype
(Comp
)) then
7475 raise Generic_Type_Subcomponent
;
7478 -- Recurse on the component type
7480 Check_Subcomponents
(Etype
(Comp
));
7482 Next_Component_Or_Discriminant
(Comp
);
7485 end Check_Subcomponents
;
7487 -- Start of processing for Check_Full_Access_Only
7490 -- Fetch the type in case we are dealing with an object or
7493 if Is_Type
(Ent
) then
7496 pragma Assert
(Is_Object
(Ent
)
7498 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7503 if not Is_Volatile
(Ent
) and then not Is_Volatile
(Typ
) then
7505 ("cannot have Full_Access_Only without Volatile/Atomic "
7509 -- Check all the subcomponents of the type recursively, if any
7511 Check_Subcomponents
(Typ
);
7514 when Full_Access_Subcomponent
=>
7516 ("cannot have Full_Access_Only with full access subcomponent "
7519 when Generic_Type_Subcomponent
=>
7521 ("cannot have Full_Access_Only with subcomponent of generic "
7522 & "type (RM C.6(8.2))");
7524 end Check_Full_Access_Only
;
7526 ------------------------------
7527 -- Mark_Component_Or_Object --
7528 ------------------------------
7530 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7532 if Prag_Id
= Pragma_Atomic
7533 or else Prag_Id
= Pragma_Shared
7534 or else Prag_Id
= Pragma_Volatile_Full_Access
7536 if Prag_Id
= Pragma_Volatile_Full_Access
then
7537 Set_Is_Volatile_Full_Access
(Ent
);
7539 Set_Is_Atomic
(Ent
);
7542 -- If the object declaration has an explicit initialization, a
7543 -- temporary may have to be created to hold the expression, to
7544 -- ensure that access to the object remains atomic.
7546 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7547 and then Present
(Expression
(Parent
(Ent
)))
7549 Set_Has_Delayed_Freeze
(Ent
);
7553 -- Atomic/Shared/Volatile_Full_Access imply Independent
7555 if Prag_Id
/= Pragma_Volatile
then
7556 Set_Is_Independent
(Ent
);
7558 if Prag_Id
= Pragma_Independent
then
7559 Record_Independence_Check
(N
, Ent
);
7563 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7565 if Prag_Id
/= Pragma_Independent
then
7566 Set_Is_Volatile
(Ent
);
7567 Set_Treat_As_Volatile
(Ent
);
7569 end Mark_Component_Or_Object
;
7575 procedure Mark_Type
(Ent
: Entity_Id
) is
7577 -- Attribute belongs on the base type. If the view of the type is
7578 -- currently private, it also belongs on the underlying type.
7580 -- In Ada 2022, the pragma can apply to a formal type, for which
7581 -- there may be no underlying type.
7583 if Prag_Id
= Pragma_Atomic
7584 or else Prag_Id
= Pragma_Shared
7585 or else Prag_Id
= Pragma_Volatile_Full_Access
7587 Set_Atomic_VFA
(Ent
);
7588 Set_Atomic_VFA
(Base_Type
(Ent
));
7590 if not Is_Generic_Type
(Ent
) then
7591 Set_Atomic_VFA
(Underlying_Type
(Ent
));
7595 -- Atomic/Shared/Volatile_Full_Access imply Independent
7597 if Prag_Id
/= Pragma_Volatile
then
7598 Set_Is_Independent
(Ent
);
7599 Set_Is_Independent
(Base_Type
(Ent
));
7601 if not Is_Generic_Type
(Ent
) then
7602 Set_Is_Independent
(Underlying_Type
(Ent
));
7604 if Prag_Id
= Pragma_Independent
then
7605 Record_Independence_Check
(N
, Base_Type
(Ent
));
7610 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7612 if Prag_Id
/= Pragma_Independent
then
7613 Set_Is_Volatile
(Ent
);
7614 Set_Is_Volatile
(Base_Type
(Ent
));
7616 if not Is_Generic_Type
(Ent
) then
7617 Set_Is_Volatile
(Underlying_Type
(Ent
));
7618 Set_Treat_As_Volatile
(Underlying_Type
(Ent
));
7621 Set_Treat_As_Volatile
(Ent
);
7624 -- Apply Volatile to the composite type's individual components,
7627 if Prag_Id
= Pragma_Volatile
7628 and then Is_Record_Type
(Etype
(Ent
))
7633 Comp
:= First_Component
(Ent
);
7634 while Present
(Comp
) loop
7635 Mark_Component_Or_Object
(Comp
);
7637 Next_Component
(Comp
);
7643 --------------------
7644 -- Set_Atomic_VFA --
7645 --------------------
7647 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7649 if Prag_Id
= Pragma_Volatile_Full_Access
then
7650 Set_Is_Volatile_Full_Access
(Ent
);
7652 Set_Is_Atomic
(Ent
);
7655 if not Has_Alignment_Clause
(Ent
) then
7656 Reinit_Alignment
(Ent
);
7666 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7669 Check_Ada_83_Warning
;
7670 Check_No_Identifiers
;
7671 Check_Arg_Count
(1);
7672 Check_Arg_Is_Local_Name
(Arg1
);
7673 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7675 if Etype
(E_Arg
) = Any_Type
then
7679 E
:= Entity
(E_Arg
);
7680 Decl
:= Declaration_Node
(E
);
7682 -- A pragma that applies to a Ghost entity becomes Ghost for the
7683 -- purposes of legality checks and removal of ignored Ghost code.
7685 Mark_Ghost_Pragma
(N
, E
);
7687 -- Check duplicate before we chain ourselves
7689 Check_Duplicate_Pragma
(E
);
7691 -- Check the constraints of Full_Access_Only in Ada 2022. Note that
7692 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
7693 -- aspect subsumes the Volatile aspect and 2) nesting is supported
7694 -- for this aspect and the outermost enclosing VFA object prevails.
7696 -- Note also that we used to forbid specifying both Atomic and VFA on
7697 -- the same type or object, but the restriction has been lifted in
7698 -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
7700 if Prag_Id
= Pragma_Volatile_Full_Access
7701 and then From_Aspect_Specification
(N
)
7703 Get_Aspect_Id
(Corresponding_Aspect
(N
)) = Aspect_Full_Access_Only
7705 Check_Full_Access_Only
(E
);
7708 -- The following check is only relevant when SPARK_Mode is on as
7709 -- this is not a standard Ada legality rule. Pragma Volatile can
7710 -- only apply to a full type declaration or an object declaration
7711 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7712 -- untagged derived types that are rewritten as subtypes of their
7713 -- respective root types.
7716 and then Prag_Id
= Pragma_Volatile
7717 and then Nkind
(Original_Node
(Decl
)) not in
7718 N_Full_Type_Declaration |
7719 N_Formal_Type_Declaration |
7720 N_Object_Declaration |
7721 N_Single_Protected_Declaration |
7722 N_Single_Task_Declaration
7725 ("argument of pragma % must denote a full type or object "
7726 & "declaration", Arg1
);
7729 -- Deal with the case where the pragma/attribute is applied to a type
7732 if Rep_Item_Too_Early
(E
, N
)
7733 or else Rep_Item_Too_Late
(E
, N
)
7737 Check_First_Subtype
(Arg1
);
7742 -- Deal with the case where the pragma/attribute applies to a
7743 -- component or object declaration.
7745 elsif Nkind
(Decl
) = N_Object_Declaration
7746 or else (Nkind
(Decl
) = N_Component_Declaration
7747 and then Original_Record_Component
(E
) = E
)
7749 if Rep_Item_Too_Late
(E
, N
) then
7753 Mark_Component_Or_Object
(E
);
7755 -- In other cases give an error
7758 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7760 end Process_Atomic_Independent_Shared_Volatile
;
7762 -------------------------------------------
7763 -- Process_Compile_Time_Warning_Or_Error --
7764 -------------------------------------------
7766 procedure Process_Compile_Time_Warning_Or_Error
is
7767 P
: Node_Id
:= Parent
(N
);
7768 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7771 Check_Arg_Count
(2);
7772 Check_No_Identifiers
;
7773 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7774 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7776 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7777 -- a Check pragma in GNATprove mode, handled as an assumption in
7778 -- GNATprove. This is correct as the compiler will issue an error
7779 -- if the condition cannot be statically evaluated to False.
7780 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7781 -- same information as the compiler (in particular regarding size of
7782 -- objects decided in gigi) so it makes no sense to issue a warning
7785 if GNATprove_Mode
then
7786 if Prag_Id
= Pragma_Compile_Time_Error
then
7790 -- Implement Compile_Time_Error by generating
7791 -- a corresponding Check pragma:
7793 -- pragma Check (name, condition);
7795 -- where name is the identifier matching the pragma name. So
7796 -- rewrite pragma in this manner and analyze the result.
7798 New_Args
:= New_List
7799 (Make_Pragma_Argument_Association
7801 Expression
=> Make_Identifier
(Loc
, Pname
)),
7802 Make_Pragma_Argument_Association
7804 Expression
=> Arg1x
));
7806 -- Rewrite as Check pragma
7810 Chars
=> Name_Check
,
7811 Pragma_Argument_Associations
=> New_Args
));
7817 Rewrite
(N
, Make_Null_Statement
(Loc
));
7823 -- If the condition is known at compile time (now), validate it now.
7824 -- Otherwise, register the expression for validation after the back
7825 -- end has been called, because it might be known at compile time
7826 -- then. For example, if the expression is "Record_Type'Size /= 32"
7827 -- it might be known after the back end has determined the size of
7828 -- Record_Type. We do not defer validation if we're inside a generic
7829 -- unit, because we will have more information in the instances.
7831 if Compile_Time_Known_Value
(Arg1x
) then
7832 Validate_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7835 while Present
(P
) and then Nkind
(P
) not in N_Generic_Declaration
7837 if (Nkind
(P
) = N_Subprogram_Body
and then not Acts_As_Spec
(P
))
7838 or else Nkind
(P
) = N_Package_Body
7840 P
:= Parent
(Corresponding_Spec
(P
));
7848 Defer_Compile_Time_Warning_Error_To_BE
(N
);
7851 end Process_Compile_Time_Warning_Or_Error
;
7853 ------------------------
7854 -- Process_Convention --
7855 ------------------------
7857 procedure Process_Convention
7858 (C
: out Convention_Id
;
7859 Ent
: out Entity_Id
)
7863 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7864 -- Called if we have more than one Export/Import/Convention pragma.
7865 -- This is generally illegal, but we have a special case of allowing
7866 -- Import and Interface to coexist if they specify the convention in
7867 -- a consistent manner. We are allowed to do this, since Interface is
7868 -- an implementation defined pragma, and we choose to do it since we
7869 -- know Rational allows this combination. S is the entity id of the
7870 -- subprogram in question. This procedure also sets the special flag
7871 -- Import_Interface_Present in both pragmas in the case where we do
7872 -- have matching Import and Interface pragmas.
7874 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7875 -- Set convention in entity E, and also flag that the entity has a
7876 -- convention pragma. If entity is for a private or incomplete type,
7877 -- also set convention and flag on underlying type. This procedure
7878 -- also deals with the special case of C_Pass_By_Copy convention,
7879 -- and error checks for inappropriate convention specification.
7881 -------------------------------
7882 -- Diagnose_Multiple_Pragmas --
7883 -------------------------------
7885 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7886 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7890 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7891 -- Decl is a pragma node. This function returns True if this
7892 -- pragma has a first argument that is an identifier with a
7893 -- Chars field corresponding to the Convention_Id C.
7895 function Same_Name
(Decl
: Node_Id
) return Boolean;
7896 -- Decl is a pragma node. This function returns True if this
7897 -- pragma has a second argument that is an identifier with a
7898 -- Chars field that matches the Chars of the current subprogram.
7900 ---------------------
7901 -- Same_Convention --
7902 ---------------------
7904 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7905 Arg1
: constant Node_Id
:=
7906 First
(Pragma_Argument_Associations
(Decl
));
7909 if Present
(Arg1
) then
7911 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7913 if Nkind
(Arg
) = N_Identifier
7914 and then Is_Convention_Name
(Chars
(Arg
))
7915 and then Get_Convention_Id
(Chars
(Arg
)) = C
7923 end Same_Convention
;
7929 function Same_Name
(Decl
: Node_Id
) return Boolean is
7930 Arg1
: constant Node_Id
:=
7931 First
(Pragma_Argument_Associations
(Decl
));
7939 Arg2
:= Next
(Arg1
);
7946 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7948 if Nkind
(Arg
) = N_Identifier
7949 and then Chars
(Arg
) = Chars
(S
)
7958 -- Start of processing for Diagnose_Multiple_Pragmas
7963 -- Definitely give message if we have Convention/Export here
7965 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7968 -- If we have an Import or Export, scan back from pragma to
7969 -- find any previous pragma applying to the same procedure.
7970 -- The scan will be terminated by the start of the list, or
7971 -- hitting the subprogram declaration. This won't allow one
7972 -- pragma to appear in the public part and one in the private
7973 -- part, but that seems very unlikely in practice.
7977 while Present
(Decl
) and then Decl
/= Pdec
loop
7979 -- Look for pragma with same name as us
7981 if Nkind
(Decl
) = N_Pragma
7982 and then Same_Name
(Decl
)
7984 -- Give error if same as our pragma or Export/Convention
7986 if Pragma_Name_Unmapped
(Decl
)
7989 | Pragma_Name_Unmapped
(N
)
7993 -- Case of Import/Interface or the other way round
7995 elsif Pragma_Name_Unmapped
(Decl
)
7996 in Name_Interface | Name_Import
7998 -- Here we know that we have Import and Interface. It
7999 -- doesn't matter which way round they are. See if
8000 -- they specify the same convention. If so, all OK,
8001 -- and set special flags to stop other messages
8003 if Same_Convention
(Decl
) then
8004 Set_Import_Interface_Present
(N
);
8005 Set_Import_Interface_Present
(Decl
);
8008 -- If different conventions, special message
8011 Error_Msg_Sloc
:= Sloc
(Decl
);
8013 ("convention differs from that given#", Arg1
);
8022 -- Give message if needed if we fall through those tests
8023 -- except on Relaxed_RM_Semantics where we let go: either this
8024 -- is a case accepted/ignored by other Ada compilers (e.g.
8025 -- a mix of Convention and Import), or another error will be
8026 -- generated later (e.g. using both Import and Export).
8028 if Err
and not Relaxed_RM_Semantics
then
8030 ("at most one Convention/Export/Import pragma is allowed",
8033 end Diagnose_Multiple_Pragmas
;
8035 --------------------------------
8036 -- Set_Convention_From_Pragma --
8037 --------------------------------
8039 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
8041 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8042 -- for an overridden dispatching operation. Technically this is
8043 -- an amendment and should only be done in Ada 2005 mode. However,
8044 -- this is clearly a mistake, since the problem that is addressed
8045 -- by this AI is that there is a clear gap in the RM.
8047 if Is_Dispatching_Operation
(E
)
8048 and then Present
(Overridden_Operation
(E
))
8049 and then C
/= Convention
(Overridden_Operation
(E
))
8052 ("cannot change convention for overridden dispatching "
8053 & "operation", Arg1
);
8055 -- Special check for convention Stdcall: a dispatching call is not
8056 -- allowed. A dispatching subprogram cannot be used to interface
8057 -- to the Win32 API, so this check actually does not impose any
8058 -- effective restriction.
8060 elsif Is_Dispatching_Operation
(E
)
8061 and then C
= Convention_Stdcall
8063 -- Note: make this unconditional so that if there is more
8064 -- than one call to which the pragma applies, we get a
8065 -- message for each call. Also don't use Error_Pragma,
8066 -- so that we get multiple messages.
8068 Error_Msg_Sloc
:= Sloc
(E
);
8070 ("dispatching subprogram# cannot use Stdcall convention!",
8071 Get_Pragma_Arg
(Arg1
));
8074 -- Set the convention
8076 Set_Convention
(E
, C
);
8077 Set_Has_Convention_Pragma
(E
);
8079 -- For the case of a record base type, also set the convention of
8080 -- any anonymous access types declared in the record which do not
8081 -- currently have a specified convention.
8082 -- Similarly for an array base type and anonymous access types
8085 if Is_Base_Type
(E
) then
8086 if Is_Record_Type
(E
) then
8091 Comp
:= First_Component
(E
);
8092 while Present
(Comp
) loop
8093 if Present
(Etype
(Comp
))
8095 Ekind
(Etype
(Comp
)) in
8096 E_Anonymous_Access_Type |
8097 E_Anonymous_Access_Subprogram_Type
8098 and then not Has_Convention_Pragma
(Comp
)
8100 Set_Convention
(Comp
, C
);
8103 Next_Component
(Comp
);
8107 elsif Is_Array_Type
(E
)
8108 and then Ekind
(Component_Type
(E
)) in
8109 E_Anonymous_Access_Type |
8110 E_Anonymous_Access_Subprogram_Type
8112 Set_Convention
(Designated_Type
(Component_Type
(E
)), C
);
8116 -- Deal with incomplete/private type case, where underlying type
8117 -- is available, so set convention of that underlying type.
8119 if Is_Incomplete_Or_Private_Type
(E
)
8120 and then Present
(Underlying_Type
(E
))
8122 Set_Convention
(Underlying_Type
(E
), C
);
8123 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
8126 -- A class-wide type should inherit the convention of the specific
8127 -- root type (although this isn't specified clearly by the RM).
8129 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
8130 Set_Convention
(Class_Wide_Type
(E
), C
);
8133 -- If the entity is a record type, then check for special case of
8134 -- C_Pass_By_Copy, which is treated the same as C except that the
8135 -- special record flag is set. This convention is only permitted
8136 -- on record types (see AI95-00131).
8138 if Cname
= Name_C_Pass_By_Copy
then
8139 if Is_Record_Type
(E
) then
8140 Set_C_Pass_By_Copy
(Base_Type
(E
));
8141 elsif Is_Incomplete_Or_Private_Type
(E
)
8142 and then Is_Record_Type
(Underlying_Type
(E
))
8144 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
8147 ("C_Pass_By_Copy convention allowed only for record type",
8152 -- If the entity is a derived boolean type, check for the special
8153 -- case of convention C, C++, or Fortran, where we consider any
8154 -- nonzero value to represent true.
8156 if Is_Discrete_Type
(E
)
8157 and then Root_Type
(Etype
(E
)) = Standard_Boolean
8163 C
= Convention_Fortran
)
8165 Set_Nonzero_Is_True
(Base_Type
(E
));
8167 end Set_Convention_From_Pragma
;
8171 Comp_Unit
: Unit_Number_Type
;
8177 -- Start of processing for Process_Convention
8180 Check_At_Least_N_Arguments
(2);
8181 Check_Optional_Identifier
(Arg1
, Name_Convention
);
8182 Check_Arg_Is_Identifier
(Arg1
);
8183 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
8185 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8186 -- tested again below to set the critical flag).
8188 if Cname
= Name_C_Pass_By_Copy
then
8191 -- Otherwise we must have something in the standard convention list
8193 elsif Is_Convention_Name
(Cname
) then
8194 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8196 -- Otherwise warn on unrecognized convention
8199 if Warn_On_Export_Import
then
8201 ("??unrecognized convention name, C assumed",
8202 Get_Pragma_Arg
(Arg1
));
8208 Check_Optional_Identifier
(Arg2
, Name_Entity
);
8209 Check_Arg_Is_Local_Name
(Arg2
);
8211 Id
:= Get_Pragma_Arg
(Arg2
);
8214 if not Is_Entity_Name
(Id
) then
8215 Error_Pragma_Arg
("entity name required", Arg2
);
8220 -- Set entity to return
8224 -- Ada_Pass_By_Copy special checking
8226 if C
= Convention_Ada_Pass_By_Copy
then
8227 if not Is_First_Subtype
(E
) then
8229 ("convention `Ada_Pass_By_Copy` only allowed for types",
8233 if Is_By_Reference_Type
(E
) then
8235 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8239 -- Ada_Pass_By_Reference special checking
8241 elsif C
= Convention_Ada_Pass_By_Reference
then
8242 if not Is_First_Subtype
(E
) then
8244 ("convention `Ada_Pass_By_Reference` only allowed for types",
8248 if Is_By_Copy_Type
(E
) then
8250 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8255 -- Go to renamed subprogram if present, since convention applies to
8256 -- the actual renamed entity, not to the renaming entity. If the
8257 -- subprogram is inherited, go to parent subprogram.
8259 if Is_Subprogram
(E
)
8260 and then Present
(Alias
(E
))
8262 if Nkind
(Parent
(Declaration_Node
(E
))) =
8263 N_Subprogram_Renaming_Declaration
8265 if Scope
(E
) /= Scope
(Alias
(E
)) then
8267 ("cannot apply pragma% to non-local entity&#", E
);
8272 elsif Nkind
(Parent
(E
)) in
8273 N_Full_Type_Declaration | N_Private_Extension_Declaration
8274 and then Scope
(E
) = Scope
(Alias
(E
))
8278 -- Return the parent subprogram the entity was inherited from
8284 -- Check that we are not applying this to a specless body. Relax this
8285 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8287 if Is_Subprogram
(E
)
8288 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8289 and then not Relaxed_RM_Semantics
8292 ("pragma% requires separate spec and must come before body");
8295 -- Check that we are not applying this to a named constant
8297 if Is_Named_Number
(E
) then
8298 Error_Msg_Name_1
:= Pname
;
8300 ("cannot apply pragma% to named constant!",
8301 Get_Pragma_Arg
(Arg2
));
8303 ("\supply appropriate type for&!", Arg2
);
8306 if Ekind
(E
) = E_Enumeration_Literal
then
8307 Error_Pragma
("enumeration literal not allowed for pragma%");
8310 -- Check for rep item appearing too early or too late
8312 if Etype
(E
) = Any_Type
8313 or else Rep_Item_Too_Early
(E
, N
)
8317 elsif Present
(Underlying_Type
(E
)) then
8318 E
:= Underlying_Type
(E
);
8321 if Rep_Item_Too_Late
(E
, N
) then
8325 if Has_Convention_Pragma
(E
) then
8326 Diagnose_Multiple_Pragmas
(E
);
8328 elsif Convention
(E
) = Convention_Protected
8329 or else Ekind
(Scope
(E
)) = E_Protected_Type
8332 ("a protected operation cannot be given a different convention",
8336 -- For Intrinsic, a subprogram is required
8338 if C
= Convention_Intrinsic
8339 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8341 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8343 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8344 if From_Aspect_Specification
(N
) then
8346 ("entity for aspect% must be a subprogram", Arg2
);
8349 ("second argument of pragma% must be a subprogram", Arg2
);
8353 -- Special checks for C_Variadic_n
8355 elsif C
in Convention_C_Variadic
then
8357 -- Several allowed cases
8359 if Is_Subprogram_Or_Generic_Subprogram
(E
) then
8362 -- An access to subprogram is also allowed
8364 elsif Is_Access_Type
(E
)
8365 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
8367 Subp
:= Designated_Type
(E
);
8369 -- Allow internal call to set convention of subprogram type
8371 elsif Ekind
(E
) = E_Subprogram_Type
then
8376 ("argument of pragma% must be subprogram or access type",
8380 -- ISO C requires a named parameter before the ellipsis, so a
8381 -- variadic C function taking 0 fixed parameter cannot exist.
8383 if C
= Convention_C_Variadic_0
then
8386 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8387 Get_Pragma_Arg
(Arg2
));
8389 -- Now check the number of parameters of the subprogram and give
8390 -- an error if it is lower than n.
8392 elsif Present
(Subp
) then
8394 Minimum
: constant Nat
:=
8395 Convention_Id
'Pos (C
) -
8396 Convention_Id
'Pos (Convention_C_Variadic_0
);
8403 Formal
:= First_Formal
(Subp
);
8404 while Present
(Formal
) loop
8406 Next_Formal
(Formal
);
8409 if Count
< Minimum
then
8410 Error_Msg_Uint_1
:= UI_From_Int
(Minimum
);
8412 ("argument of pragma% must have at least"
8413 & "^ parameters", Arg2
);
8418 -- Special checks for Stdcall
8420 elsif C
= Convention_Stdcall
then
8422 -- Several allowed cases
8424 if Is_Subprogram_Or_Generic_Subprogram
(E
)
8428 or else Ekind
(E
) = E_Variable
8430 -- A component as well. The entity does not have its Ekind
8431 -- set until the enclosing record declaration is fully
8434 or else Nkind
(Parent
(E
)) = N_Component_Declaration
8436 -- An access to subprogram is also allowed
8440 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
8442 -- Allow internal call to set convention of subprogram type
8444 or else Ekind
(E
) = E_Subprogram_Type
8450 ("argument of pragma% must be subprogram or access type",
8455 Set_Convention_From_Pragma
(E
);
8457 -- Deal with non-subprogram cases
8459 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8462 -- The pragma must apply to a first subtype, but it can also
8463 -- apply to a generic type in a generic formal part, in which
8464 -- case it will also appear in the corresponding instance.
8466 if Is_Generic_Type
(E
) or else In_Instance
then
8469 Check_First_Subtype
(Arg2
);
8472 Set_Convention_From_Pragma
(Base_Type
(E
));
8474 -- For access subprograms, we must set the convention on the
8475 -- internally generated directly designated type as well.
8477 if Ekind
(E
) = E_Access_Subprogram_Type
then
8478 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8482 -- For the subprogram case, set proper convention for all homonyms
8483 -- in same scope and the same declarative part, i.e. the same
8484 -- compilation unit.
8487 -- Treat a pragma Import as an implicit body, and pragma import
8488 -- as implicit reference (for navigation in GNAT Studio).
8490 if Prag_Id
= Pragma_Import
then
8491 Generate_Reference
(E
, Id
, 'b');
8493 -- For exported entities we restrict the generation of references
8494 -- to entities exported to foreign languages since entities
8495 -- exported to Ada do not provide further information to
8496 -- GNAT Studio and add undesired references to the output of the
8499 elsif Prag_Id
= Pragma_Export
8500 and then Convention
(E
) /= Convention_Ada
8502 Generate_Reference
(E
, Id
, 'i');
8505 -- If the pragma comes from an aspect, it only applies to the
8506 -- given entity, not its homonyms.
8508 if From_Aspect_Specification
(N
) then
8509 if C
= Convention_Intrinsic
8510 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8512 if Is_Fixed_Point_Type
(Etype
(Ent
))
8513 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8514 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8517 ("no intrinsic operator available for this fixed-point "
8520 ("\use expression functions with the desired "
8521 & "conversions made explicit", N
);
8528 -- Otherwise Loop through the homonyms of the pragma argument's
8529 -- entity, an apply convention to those in the current scope.
8531 Comp_Unit
:= Get_Source_Unit
(E
);
8536 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8538 -- Ignore entry for which convention is already set
8540 if Has_Convention_Pragma
(E1
) then
8544 if Is_Subprogram
(E1
)
8545 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8547 and then not Relaxed_RM_Semantics
8549 Set_Has_Completion
(E
); -- to prevent cascaded error
8551 ("pragma% requires separate spec and must come before "
8555 -- Do not set the pragma on inherited operations or on formal
8558 if Comes_From_Source
(E1
)
8559 and then Comp_Unit
= Get_Source_Unit
(E1
)
8560 and then not Is_Formal_Subprogram
(E1
)
8561 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8562 N_Full_Type_Declaration
8564 if Present
(Alias
(E1
))
8565 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8568 ("cannot apply pragma% to non-local entity& declared#",
8572 Set_Convention_From_Pragma
(E1
);
8574 if Prag_Id
= Pragma_Import
then
8575 Generate_Reference
(E1
, Id
, 'b');
8583 end Process_Convention
;
8585 ----------------------------------------
8586 -- Process_Disable_Enable_Atomic_Sync --
8587 ----------------------------------------
8589 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8591 Check_No_Identifiers
;
8592 Check_At_Most_N_Arguments
(1);
8594 -- Modeled internally as
8595 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8600 Pragma_Argument_Associations
=> New_List
(
8601 Make_Pragma_Argument_Association
(Loc
,
8603 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8605 if Present
(Arg1
) then
8606 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8610 end Process_Disable_Enable_Atomic_Sync
;
8612 -------------------------------------------------
8613 -- Process_Extended_Import_Export_Internal_Arg --
8614 -------------------------------------------------
8616 procedure Process_Extended_Import_Export_Internal_Arg
8617 (Arg_Internal
: Node_Id
:= Empty
)
8620 if No
(Arg_Internal
) then
8621 Error_Pragma
("Internal parameter required for pragma%");
8624 if Nkind
(Arg_Internal
) = N_Identifier
then
8627 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8628 and then (Prag_Id
= Pragma_Import_Function
8630 Prag_Id
= Pragma_Export_Function
)
8636 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8639 Check_Arg_Is_Local_Name
(Arg_Internal
);
8640 end Process_Extended_Import_Export_Internal_Arg
;
8642 --------------------------------------------------
8643 -- Process_Extended_Import_Export_Object_Pragma --
8644 --------------------------------------------------
8646 procedure Process_Extended_Import_Export_Object_Pragma
8647 (Arg_Internal
: Node_Id
;
8648 Arg_External
: Node_Id
;
8654 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8655 Def_Id
:= Entity
(Arg_Internal
);
8657 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
8659 ("pragma% must designate an object", Arg_Internal
);
8662 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8664 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8667 ("previous Common/Psect_Object applies, pragma % not permitted",
8671 if Rep_Item_Too_Late
(Def_Id
, N
) then
8675 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8677 if Present
(Arg_Size
) then
8678 Check_Arg_Is_External_Name
(Arg_Size
);
8681 -- Export_Object case
8683 if Prag_Id
= Pragma_Export_Object
then
8684 if not Is_Library_Level_Entity
(Def_Id
) then
8686 ("argument for pragma% must be library level entity",
8690 if Ekind
(Current_Scope
) = E_Generic_Package
then
8691 Error_Pragma
("pragma& cannot appear in a generic unit");
8694 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8696 ("exported object must have compile time known size",
8700 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8701 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8703 Set_Exported
(Def_Id
, Arg_Internal
);
8706 -- Import_Object case
8709 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8711 ("cannot use pragma% for task/protected object",
8715 if Ekind
(Def_Id
) = E_Constant
then
8717 ("cannot import a constant", Arg_Internal
);
8720 if Warn_On_Export_Import
8721 and then Has_Discriminants
(Etype
(Def_Id
))
8724 ("imported value must be initialized??", Arg_Internal
);
8727 if Warn_On_Export_Import
8728 and then Is_Access_Type
(Etype
(Def_Id
))
8731 ("cannot import object of an access type??", Arg_Internal
);
8734 if Warn_On_Export_Import
8735 and then Is_Imported
(Def_Id
)
8737 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8739 -- Check for explicit initialization present. Note that an
8740 -- initialization generated by the code generator, e.g. for an
8741 -- access type, does not count here.
8743 elsif Present
(Expression
(Parent
(Def_Id
)))
8746 (Original_Node
(Expression
(Parent
(Def_Id
))))
8748 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8750 ("imported entities cannot be initialized (RM B.1(24))",
8751 "\no initialization allowed for & declared#", Arg1
);
8753 Set_Imported
(Def_Id
);
8754 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8757 end Process_Extended_Import_Export_Object_Pragma
;
8759 ------------------------------------------------------
8760 -- Process_Extended_Import_Export_Subprogram_Pragma --
8761 ------------------------------------------------------
8763 procedure Process_Extended_Import_Export_Subprogram_Pragma
8764 (Arg_Internal
: Node_Id
;
8765 Arg_External
: Node_Id
;
8766 Arg_Parameter_Types
: Node_Id
;
8767 Arg_Result_Type
: Node_Id
:= Empty
;
8768 Arg_Mechanism
: Node_Id
;
8769 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8775 Ambiguous
: Boolean;
8778 function Same_Base_Type
8780 Formal
: Entity_Id
) return Boolean;
8781 -- Determines if Ptype references the type of Formal. Note that only
8782 -- the base types need to match according to the spec. Ptype here is
8783 -- the argument from the pragma, which is either a type name, or an
8784 -- access attribute.
8786 --------------------
8787 -- Same_Base_Type --
8788 --------------------
8790 function Same_Base_Type
8792 Formal
: Entity_Id
) return Boolean
8794 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8798 -- Case where pragma argument is typ'Access
8800 if Nkind
(Ptype
) = N_Attribute_Reference
8801 and then Attribute_Name
(Ptype
) = Name_Access
8803 Pref
:= Prefix
(Ptype
);
8806 if not Is_Entity_Name
(Pref
)
8807 or else Entity
(Pref
) = Any_Type
8812 -- We have a match if the corresponding argument is of an
8813 -- anonymous access type, and its designated type matches the
8814 -- type of the prefix of the access attribute
8816 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8817 and then Base_Type
(Entity
(Pref
)) =
8818 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8820 -- Case where pragma argument is a type name
8825 if not Is_Entity_Name
(Ptype
)
8826 or else Entity
(Ptype
) = Any_Type
8831 -- We have a match if the corresponding argument is of the type
8832 -- given in the pragma (comparing base types)
8834 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8838 -- Start of processing for
8839 -- Process_Extended_Import_Export_Subprogram_Pragma
8842 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8846 -- Loop through homonyms (overloadings) of the entity
8848 Hom_Id
:= Entity
(Arg_Internal
);
8849 while Present
(Hom_Id
) loop
8850 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8852 -- We need a subprogram in the current scope
8854 if not Is_Subprogram
(Def_Id
)
8855 or else Scope
(Def_Id
) /= Current_Scope
8862 -- Pragma cannot apply to subprogram body
8864 if Is_Subprogram
(Def_Id
)
8865 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8869 ("pragma% requires separate spec and must come before "
8873 -- Test result type if given, note that the result type
8874 -- parameter can only be present for the function cases.
8876 if Present
(Arg_Result_Type
)
8877 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8881 elsif Etype
(Def_Id
) /= Standard_Void_Type
8883 Pname
in Name_Export_Procedure | Name_Import_Procedure
8887 -- Test parameter types if given. Note that this parameter has
8888 -- not been analyzed (and must not be, since it is semantic
8889 -- nonsense), so we get it as the parser left it.
8891 elsif Present
(Arg_Parameter_Types
) then
8892 Check_Matching_Types
: declare
8897 Formal
:= First_Formal
(Def_Id
);
8899 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8900 if Present
(Formal
) then
8904 -- A list of one type, e.g. (List) is parsed as a
8905 -- parenthesized expression.
8907 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8908 and then Paren_Count
(Arg_Parameter_Types
) = 1
8911 or else Present
(Next_Formal
(Formal
))
8916 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8919 -- A list of more than one type is parsed as a aggregate
8921 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8922 and then Paren_Count
(Arg_Parameter_Types
) = 0
8924 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8925 while Present
(Ptype
) or else Present
(Formal
) loop
8928 or else not Same_Base_Type
(Ptype
, Formal
)
8933 Next_Formal
(Formal
);
8938 -- Anything else is of the wrong form
8942 ("wrong form for Parameter_Types parameter",
8943 Arg_Parameter_Types
);
8945 end Check_Matching_Types
;
8948 -- Match is now False if the entry we found did not match
8949 -- either a supplied Parameter_Types or Result_Types argument
8955 -- Ambiguous case, the flag Ambiguous shows if we already
8956 -- detected this and output the initial messages.
8959 if not Ambiguous
then
8961 Error_Msg_Name_1
:= Pname
;
8963 ("pragma% does not uniquely identify subprogram!",
8965 Error_Msg_Sloc
:= Sloc
(Ent
);
8966 Error_Msg_N
("matching subprogram #!", N
);
8970 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8971 Error_Msg_N
("matching subprogram #!", N
);
8976 Hom_Id
:= Homonym
(Hom_Id
);
8979 -- See if we found an entry
8982 if not Ambiguous
then
8983 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8985 ("pragma% cannot be given for generic subprogram");
8988 ("pragma% does not identify local subprogram");
8995 -- Import pragmas must be for imported entities
8997 if Prag_Id
= Pragma_Import_Function
8999 Prag_Id
= Pragma_Import_Procedure
9001 Prag_Id
= Pragma_Import_Valued_Procedure
9003 if not Is_Imported
(Ent
) then
9005 ("pragma Import or Interface must precede pragma%");
9008 -- Here we have the Export case which can set the entity as exported
9010 -- But does not do so if the specified external name is null, since
9011 -- that is taken as a signal in DEC Ada 83 (with which we want to be
9012 -- compatible) to request no external name.
9014 elsif Nkind
(Arg_External
) = N_String_Literal
9015 and then String_Length
(Strval
(Arg_External
)) = 0
9019 -- In all other cases, set entity as exported
9022 Set_Exported
(Ent
, Arg_Internal
);
9025 -- Special processing for Valued_Procedure cases
9027 if Prag_Id
= Pragma_Import_Valued_Procedure
9029 Prag_Id
= Pragma_Export_Valued_Procedure
9031 Formal
:= First_Formal
(Ent
);
9034 Error_Pragma
("at least one parameter required for pragma%");
9036 elsif Ekind
(Formal
) /= E_Out_Parameter
then
9037 Error_Pragma
("first parameter must have mode OUT for pragma%");
9040 Set_Is_Valued_Procedure
(Ent
);
9044 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
9046 -- Process Result_Mechanism argument if present. We have already
9047 -- checked that this is only allowed for the function case.
9049 if Present
(Arg_Result_Mechanism
) then
9050 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
9053 -- Process Mechanism parameter if present. Note that this parameter
9054 -- is not analyzed, and must not be analyzed since it is semantic
9055 -- nonsense, so we get it in exactly as the parser left it.
9057 if Present
(Arg_Mechanism
) then
9065 -- A single mechanism association without a formal parameter
9066 -- name is parsed as a parenthesized expression. All other
9067 -- cases are parsed as aggregates, so we rewrite the single
9068 -- parameter case as an aggregate for consistency.
9070 if Nkind
(Arg_Mechanism
) /= N_Aggregate
9071 and then Paren_Count
(Arg_Mechanism
) = 1
9073 Rewrite
(Arg_Mechanism
,
9074 Make_Aggregate
(Sloc
(Arg_Mechanism
),
9075 Expressions
=> New_List
(
9076 Relocate_Node
(Arg_Mechanism
))));
9079 -- Case of only mechanism name given, applies to all formals
9081 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
9082 Formal
:= First_Formal
(Ent
);
9083 while Present
(Formal
) loop
9084 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
9085 Next_Formal
(Formal
);
9088 -- Case of list of mechanism associations given
9091 if Null_Record_Present
(Arg_Mechanism
) then
9093 ("inappropriate form for Mechanism parameter",
9097 -- Deal with positional ones first
9099 Formal
:= First_Formal
(Ent
);
9101 if Present
(Expressions
(Arg_Mechanism
)) then
9102 Mname
:= First
(Expressions
(Arg_Mechanism
));
9103 while Present
(Mname
) loop
9106 ("too many mechanism associations", Mname
);
9109 Set_Mechanism_Value
(Formal
, Mname
);
9110 Next_Formal
(Formal
);
9115 -- Deal with named entries
9117 if Present
(Component_Associations
(Arg_Mechanism
)) then
9118 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
9119 while Present
(Massoc
) loop
9120 Choice
:= First
(Choices
(Massoc
));
9122 if Nkind
(Choice
) /= N_Identifier
9123 or else Present
(Next
(Choice
))
9126 ("incorrect form for mechanism association",
9130 Formal
:= First_Formal
(Ent
);
9134 ("parameter name & not present", Choice
);
9137 if Chars
(Choice
) = Chars
(Formal
) then
9139 (Formal
, Expression
(Massoc
));
9141 -- Set entity on identifier for proper tree
9144 Set_Entity
(Choice
, Formal
);
9149 Next_Formal
(Formal
);
9158 end Process_Extended_Import_Export_Subprogram_Pragma
;
9160 --------------------------
9161 -- Process_Generic_List --
9162 --------------------------
9164 procedure Process_Generic_List
is
9169 Check_No_Identifiers
;
9170 Check_At_Least_N_Arguments
(1);
9172 -- Check all arguments are names of generic units or instances
9175 while Present
(Arg
) loop
9176 Exp
:= Get_Pragma_Arg
(Arg
);
9179 if not Is_Entity_Name
(Exp
)
9181 (not Is_Generic_Instance
(Entity
(Exp
))
9183 not Is_Generic_Unit
(Entity
(Exp
)))
9186 ("pragma% argument must be name of generic unit/instance",
9192 end Process_Generic_List
;
9194 ------------------------------------
9195 -- Process_Import_Predefined_Type --
9196 ------------------------------------
9198 procedure Process_Import_Predefined_Type
is
9199 Loc
: constant Source_Ptr
:= Sloc
(N
);
9201 Ftyp
: Node_Id
:= Empty
;
9207 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
9209 Elmt
:= First_Elmt
(Predefined_Float_Types
);
9210 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
9214 Ftyp
:= Node
(Elmt
);
9216 if Present
(Ftyp
) then
9218 -- Don't build a derived type declaration, because predefined C
9219 -- types have no declaration anywhere, so cannot really be named.
9220 -- Instead build a full type declaration, starting with an
9221 -- appropriate type definition is built
9223 if Is_Floating_Point_Type
(Ftyp
) then
9224 Def
:= Make_Floating_Point_Definition
(Loc
,
9225 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
9226 Make_Real_Range_Specification
(Loc
,
9227 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
9228 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
9230 -- Should never have a predefined type we cannot handle
9233 raise Program_Error
;
9236 -- Build and insert a Full_Type_Declaration, which will be
9237 -- analyzed as soon as this list entry has been analyzed.
9239 Decl
:= Make_Full_Type_Declaration
(Loc
,
9240 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
9241 Type_Definition
=> Def
);
9243 Insert_After
(N
, Decl
);
9244 Mark_Rewrite_Insertion
(Decl
);
9247 Error_Pragma_Arg
("no matching type found for pragma%", Arg2
);
9249 end Process_Import_Predefined_Type
;
9251 ---------------------------------
9252 -- Process_Import_Or_Interface --
9253 ---------------------------------
9255 procedure Process_Import_Or_Interface
is
9261 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9262 -- pragma Import (Entity, "external name");
9264 if Relaxed_RM_Semantics
9265 and then Arg_Count
= 2
9266 and then Prag_Id
= Pragma_Import
9267 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
9270 Def_Id
:= Get_Pragma_Arg
(Arg1
);
9273 if not Is_Entity_Name
(Def_Id
) then
9274 Error_Pragma_Arg
("entity name required", Arg1
);
9277 Def_Id
:= Entity
(Def_Id
);
9278 Kill_Size_Check_Code
(Def_Id
);
9279 if Ekind
(Def_Id
) /= E_Constant
then
9280 Note_Possible_Modification
9281 (Get_Pragma_Arg
(Arg1
), Sure
=> False);
9285 Process_Convention
(C
, Def_Id
);
9287 -- A pragma that applies to a Ghost entity becomes Ghost for the
9288 -- purposes of legality checks and removal of ignored Ghost code.
9290 Mark_Ghost_Pragma
(N
, Def_Id
);
9291 Kill_Size_Check_Code
(Def_Id
);
9292 if Ekind
(Def_Id
) /= E_Constant
then
9293 Note_Possible_Modification
9294 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
9298 -- Various error checks
9300 if Ekind
(Def_Id
) in E_Variable | E_Constant
then
9302 -- We do not permit Import to apply to a renaming declaration
9304 if Present
(Renamed_Object
(Def_Id
)) then
9306 ("pragma% not allowed for object renaming", Arg2
);
9308 -- User initialization is not allowed for imported object, but
9309 -- the object declaration may contain a default initialization,
9310 -- that will be discarded. Note that an explicit initialization
9311 -- only counts if it comes from source, otherwise it is simply
9312 -- the code generator making an implicit initialization explicit.
9314 elsif Present
(Expression
(Parent
(Def_Id
)))
9315 and then Comes_From_Source
9316 (Original_Node
(Expression
(Parent
(Def_Id
))))
9318 -- Set imported flag to prevent cascaded errors
9320 Set_Is_Imported
(Def_Id
);
9322 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9324 ("no initialization allowed for declaration of& #",
9325 "\imported entities cannot be initialized (RM B.1(24))",
9329 -- If the pragma comes from an aspect specification the
9330 -- Is_Imported flag has already been set.
9332 if not From_Aspect_Specification
(N
) then
9333 Set_Imported
(Def_Id
);
9336 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9338 -- Note that we do not set Is_Public here. That's because we
9339 -- only want to set it if there is no address clause, and we
9340 -- don't know that yet, so we delay that processing till
9343 -- pragma Import completes deferred constants
9345 if Ekind
(Def_Id
) = E_Constant
then
9346 Set_Has_Completion
(Def_Id
);
9349 -- It is not possible to import a constant of an unconstrained
9350 -- array type (e.g. string) because there is no simple way to
9351 -- write a meaningful subtype for it.
9353 if Is_Array_Type
(Etype
(Def_Id
))
9354 and then not Is_Constrained
(Etype
(Def_Id
))
9357 ("imported constant& must have a constrained subtype",
9362 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9364 -- If the name is overloaded, pragma applies to all of the denoted
9365 -- entities in the same declarative part, unless the pragma comes
9366 -- from an aspect specification or was generated by the compiler
9367 -- (such as for pragma Provide_Shift_Operators).
9370 while Present
(Hom_Id
) loop
9372 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9374 -- Ignore inherited subprograms because the pragma will apply
9375 -- to the parent operation, which is the one called.
9377 if Is_Overloadable
(Def_Id
)
9378 and then Present
(Alias
(Def_Id
))
9382 -- If it is not a subprogram, it must be in an outer scope and
9383 -- pragma does not apply.
9385 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9388 -- The pragma does not apply to primitives of interfaces
9390 elsif Is_Dispatching_Operation
(Def_Id
)
9391 and then Present
(Find_Dispatching_Type
(Def_Id
))
9392 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9396 -- Verify that the homonym is in the same declarative part (not
9397 -- just the same scope). If the pragma comes from an aspect
9398 -- specification we know that it is part of the declaration.
9400 elsif (No
(Unit_Declaration_Node
(Def_Id
))
9401 or else Parent
(Unit_Declaration_Node
(Def_Id
)) /=
9403 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9404 and then not From_Aspect_Specification
(N
)
9409 -- If the pragma comes from an aspect specification the
9410 -- Is_Imported flag has already been set.
9412 if not From_Aspect_Specification
(N
) then
9413 Set_Imported
(Def_Id
);
9416 -- Reject an Import applied to an abstract subprogram
9418 if Is_Subprogram
(Def_Id
)
9419 and then Is_Abstract_Subprogram
(Def_Id
)
9421 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9423 ("cannot import abstract subprogram& declared#",
9427 -- Special processing for Convention_Intrinsic
9429 if C
= Convention_Intrinsic
then
9431 -- Link_Name argument not allowed for intrinsic
9435 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9437 -- If no external name is present, then check that this
9438 -- is a valid intrinsic subprogram. If an external name
9439 -- is present, then this is handled by the back end.
9442 Check_Intrinsic_Subprogram
9443 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9447 -- Verify that the subprogram does not have a completion
9448 -- through a renaming declaration. For other completions the
9449 -- pragma appears as a too late representation.
9452 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9456 and then Nkind
(Decl
) = N_Subprogram_Declaration
9457 and then Present
(Corresponding_Body
(Decl
))
9458 and then Nkind
(Unit_Declaration_Node
9459 (Corresponding_Body
(Decl
))) =
9460 N_Subprogram_Renaming_Declaration
9462 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9464 ("cannot import&, renaming already provided for "
9465 & "declaration #", N
, Def_Id
);
9469 -- If the pragma comes from an aspect specification, there
9470 -- must be an Import aspect specified as well. In the rare
9471 -- case where Import is set to False, the subprogram needs
9472 -- to have a local completion.
9475 Imp_Aspect
: constant Node_Id
:=
9476 Find_Aspect
(Def_Id
, Aspect_Import
);
9480 if Present
(Imp_Aspect
)
9481 and then Present
(Expression
(Imp_Aspect
))
9483 Expr
:= Expression
(Imp_Aspect
);
9484 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9486 if Is_Entity_Name
(Expr
)
9487 and then Entity
(Expr
) = Standard_True
9489 Set_Has_Completion
(Def_Id
);
9492 -- If there is no expression, the default is True, as for
9493 -- all boolean aspects. Same for the older pragma.
9496 Set_Has_Completion
(Def_Id
);
9500 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9503 if Is_Compilation_Unit
(Hom_Id
) then
9505 -- Its possible homonyms are not affected by the pragma.
9506 -- Such homonyms might be present in the context of other
9507 -- units being compiled.
9511 elsif From_Aspect_Specification
(N
) then
9514 -- If the pragma was created by the compiler, then we don't
9515 -- want it to apply to other homonyms. This kind of case can
9516 -- occur when using pragma Provide_Shift_Operators, which
9517 -- generates implicit shift and rotate operators with Import
9518 -- pragmas that might apply to earlier explicit or implicit
9519 -- declarations marked with Import (for example, coming from
9520 -- an earlier pragma Provide_Shift_Operators for another type),
9521 -- and we don't generally want other homonyms being treated
9522 -- as imported or the pragma flagged as an illegal duplicate.
9524 elsif not Comes_From_Source
(N
) then
9528 Hom_Id
:= Homonym
(Hom_Id
);
9532 -- Import a CPP class
9534 elsif C
= Convention_CPP
9535 and then (Is_Record_Type
(Def_Id
)
9536 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9538 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9539 if Present
(Full_View
(Def_Id
)) then
9540 Def_Id
:= Full_View
(Def_Id
);
9544 ("cannot import 'C'P'P type before full declaration seen",
9545 Get_Pragma_Arg
(Arg2
));
9547 -- Although we have reported the error we decorate it as
9548 -- CPP_Class to avoid reporting spurious errors
9550 Set_Is_CPP_Class
(Def_Id
);
9555 -- Types treated as CPP classes must be declared limited (note:
9556 -- this used to be a warning but there is no real benefit to it
9557 -- since we did effectively intend to treat the type as limited
9560 if not Is_Limited_Type
(Def_Id
) then
9562 ("imported 'C'P'P type must be limited",
9563 Get_Pragma_Arg
(Arg2
));
9566 if Etype
(Def_Id
) /= Def_Id
9567 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9569 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9572 Set_Is_CPP_Class
(Def_Id
);
9574 -- Imported CPP types must not have discriminants (because C++
9575 -- classes do not have discriminants).
9577 if Has_Discriminants
(Def_Id
) then
9579 ("imported 'C'P'P type cannot have discriminants",
9580 First
(Discriminant_Specifications
9581 (Declaration_Node
(Def_Id
))));
9584 -- Check that components of imported CPP types do not have default
9585 -- expressions. For private types this check is performed when the
9586 -- full view is analyzed (see Process_Full_View).
9588 if not Is_Private_Type
(Def_Id
) then
9589 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9592 -- Import a CPP exception
9594 elsif C
= Convention_CPP
9595 and then Ekind
(Def_Id
) = E_Exception
9599 ("'External_'Name arguments is required for 'Cpp exception",
9602 -- As only a string is allowed, Check_Arg_Is_External_Name
9605 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9608 if Present
(Arg4
) then
9610 ("Link_Name argument not allowed for imported Cpp exception",
9614 -- Do not call Set_Interface_Name as the name of the exception
9615 -- shouldn't be modified (and in particular it shouldn't be
9616 -- the External_Name). For exceptions, the External_Name is the
9617 -- name of the RTTI structure.
9619 -- ??? Emit an error if pragma Import/Export_Exception is present
9621 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9623 Check_Arg_Count
(3);
9624 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9626 Process_Import_Predefined_Type
;
9628 -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada
9629 -- compilers may accept more cases, e.g. JGNAT allowed importing
9632 elsif not Relaxed_RM_Semantics
then
9633 if From_Aspect_Specification
(N
) then
9635 ("entity for aspect% must be object, subprogram "
9636 & "or incomplete type",
9640 ("second argument of pragma% must be object, subprogram "
9641 & "or incomplete type",
9646 -- If this pragma applies to a compilation unit, then the unit, which
9647 -- is a subprogram, does not require (or allow) a body. We also do
9648 -- not need to elaborate imported procedures.
9650 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9652 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9654 Set_Body_Required
(Cunit
, False);
9657 end Process_Import_Or_Interface
;
9659 --------------------
9660 -- Process_Inline --
9661 --------------------
9663 procedure Process_Inline
(Status
: Inline_Status
) is
9670 Ghost_Error_Posted
: Boolean := False;
9671 -- Flag set when an error concerning the illegal mix of Ghost and
9672 -- non-Ghost subprograms is emitted.
9674 Ghost_Id
: Entity_Id
:= Empty
;
9675 -- The entity of the first Ghost subprogram encountered while
9676 -- processing the arguments of the pragma.
9678 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9679 -- Verify the placement of pragma Inline_Always with respect to the
9680 -- initial declaration of subprogram Spec_Id.
9682 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9683 -- Returns True if it can be determined at this stage that inlining
9684 -- is not possible, for example if the body is available and contains
9685 -- exception handlers, we prevent inlining, since otherwise we can
9686 -- get undefined symbols at link time. This function also emits a
9687 -- warning if the pragma appears too late.
9689 -- ??? is business with link symbols still valid, or does it relate
9690 -- to front end ZCX which is being phased out ???
9692 procedure Make_Inline
(Subp
: Entity_Id
);
9693 -- Subp is the defining unit name of the subprogram declaration. If
9694 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9695 -- the corresponding body, if there is one present.
9697 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9698 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9699 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9701 -----------------------------------
9702 -- Check_Inline_Always_Placement --
9703 -----------------------------------
9705 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9706 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9708 function Compilation_Unit_OK
return Boolean;
9709 pragma Inline
(Compilation_Unit_OK
);
9710 -- Determine whether pragma Inline_Always applies to a compatible
9711 -- compilation unit denoted by Spec_Id.
9713 function Declarative_List_OK
return Boolean;
9714 pragma Inline
(Declarative_List_OK
);
9715 -- Determine whether the initial declaration of subprogram Spec_Id
9716 -- and the pragma appear in compatible declarative lists.
9718 function Subprogram_Body_OK
return Boolean;
9719 pragma Inline
(Subprogram_Body_OK
);
9720 -- Determine whether pragma Inline_Always applies to a compatible
9721 -- subprogram body denoted by Spec_Id.
9723 -------------------------
9724 -- Compilation_Unit_OK --
9725 -------------------------
9727 function Compilation_Unit_OK
return Boolean is
9728 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9731 -- The pragma appears after the initial declaration of a
9732 -- compilation unit.
9734 -- procedure Comp_Unit;
9735 -- pragma Inline_Always (Comp_Unit);
9737 -- Note that for compatibility reasons, the following case is
9740 -- procedure Stand_Alone_Body_Comp_Unit is
9742 -- end Stand_Alone_Body_Comp_Unit;
9743 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9746 Nkind
(Comp_Unit
) = N_Compilation_Unit
9747 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9748 and then Is_List_Member
(N
)
9749 and then List_Containing
(N
) =
9750 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9751 end Compilation_Unit_OK
;
9753 -------------------------
9754 -- Declarative_List_OK --
9755 -------------------------
9757 function Declarative_List_OK
return Boolean is
9758 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9760 Init_Decl
: Node_Id
;
9761 Init_List
: List_Id
;
9762 Prag_List
: List_Id
;
9765 -- Determine the proper initial declaration. In general this is
9766 -- the declaration node of the subprogram except when the input
9767 -- denotes a generic instantiation.
9769 -- procedure Inst is new Gen;
9770 -- pragma Inline_Always (Inst);
9772 -- In this case the original subprogram is moved inside an
9773 -- anonymous package while pragma Inline_Always remains at the
9774 -- level of the anonymous package. Use the declaration of the
9775 -- package because it reflects the placement of the original
9778 -- package Anon_Pack is
9779 -- procedure Inst is ... end Inst; -- original
9782 -- procedure Inst renames Anon_Pack.Inst;
9783 -- pragma Inline_Always (Inst);
9785 if Is_Generic_Instance
(Spec_Id
) then
9786 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9787 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9789 Init_Decl
:= Spec_Decl
;
9792 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9793 Init_List
:= List_Containing
(Init_Decl
);
9794 Prag_List
:= List_Containing
(N
);
9796 -- The pragma and then initial declaration appear within the
9797 -- same declarative list.
9799 if Init_List
= Prag_List
then
9802 -- A special case of the above is when both the pragma and
9803 -- the initial declaration appear in different lists of a
9804 -- package spec, protected definition, or a task definition.
9809 -- pragma Inline_Always (Proc);
9812 elsif Nkind
(Context
) in N_Package_Specification
9813 | N_Protected_Definition
9815 and then Init_List
= Visible_Declarations
(Context
)
9816 and then Prag_List
= Private_Declarations
(Context
)
9823 end Declarative_List_OK
;
9825 ------------------------
9826 -- Subprogram_Body_OK --
9827 ------------------------
9829 function Subprogram_Body_OK
return Boolean is
9830 Body_Decl
: Node_Id
;
9833 -- The pragma appears within the declarative list of a stand-
9834 -- alone subprogram body.
9836 -- procedure Stand_Alone_Body is
9837 -- pragma Inline_Always (Stand_Alone_Body);
9840 -- end Stand_Alone_Body;
9842 -- The compiler creates a dummy spec in this case, however the
9843 -- pragma remains within the declarative list of the body.
9845 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9846 and then not Comes_From_Source
(Spec_Decl
)
9847 and then Present
(Corresponding_Body
(Spec_Decl
))
9850 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9852 if Present
(Declarations
(Body_Decl
))
9853 and then Is_List_Member
(N
)
9854 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9861 end Subprogram_Body_OK
;
9863 -- Start of processing for Check_Inline_Always_Placement
9866 -- This check is relevant only for pragma Inline_Always
9868 if Pname
/= Name_Inline_Always
then
9871 -- Nothing to do when the pragma is internally generated on the
9872 -- assumption that it is properly placed.
9874 elsif not Comes_From_Source
(N
) then
9877 -- Nothing to do for internally generated subprograms that act
9878 -- as accidental homonyms of a source subprogram being inlined.
9880 elsif not Comes_From_Source
(Spec_Id
) then
9883 -- Nothing to do for generic formal subprograms that act as
9884 -- homonyms of another source subprogram being inlined.
9886 elsif Is_Formal_Subprogram
(Spec_Id
) then
9889 elsif Compilation_Unit_OK
9890 or else Declarative_List_OK
9891 or else Subprogram_Body_OK
9896 -- At this point it is known that the pragma applies to or appears
9897 -- within a completing body, a completing stub, or a subunit.
9899 Error_Msg_Name_1
:= Pname
;
9900 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9901 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9904 ("pragma % must appear on initial declaration of subprogram "
9905 & "% defined #", N
);
9906 end Check_Inline_Always_Placement
;
9908 ---------------------------
9909 -- Inlining_Not_Possible --
9910 ---------------------------
9912 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9913 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9917 if Nkind
(Decl
) = N_Subprogram_Body
then
9918 Stats
:= Handled_Statement_Sequence
(Decl
);
9919 return Present
(Exception_Handlers
(Stats
))
9920 or else Present
(At_End_Proc
(Stats
));
9922 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9923 and then Present
(Corresponding_Body
(Decl
))
9925 if Analyzed
(Corresponding_Body
(Decl
)) then
9926 Error_Msg_N
("pragma appears too late, ignored??", N
);
9929 -- If the subprogram is a renaming as body, the body is just a
9930 -- call to the renamed subprogram, and inlining is trivially
9934 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9935 N_Subprogram_Renaming_Declaration
9941 Handled_Statement_Sequence
9942 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9945 Present
(Exception_Handlers
(Stats
))
9946 or else Present
(At_End_Proc
(Stats
));
9950 -- If body is not available, assume the best, the check is
9951 -- performed again when compiling enclosing package bodies.
9955 end Inlining_Not_Possible
;
9961 procedure Make_Inline
(Subp
: Entity_Id
) is
9962 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9963 Inner_Subp
: Entity_Id
:= Subp
;
9966 -- Ignore if bad type, avoid cascaded error
9968 if Etype
(Subp
) = Any_Type
then
9972 -- If inlining is not possible, for now do not treat as an error
9974 elsif Status
/= Suppressed
9975 and then Front_End_Inlining
9976 and then Inlining_Not_Possible
(Subp
)
9981 -- Here we have a candidate for inlining, but we must exclude
9982 -- derived operations. Otherwise we would end up trying to inline
9983 -- a phantom declaration, and the result would be to drag in a
9984 -- body which has no direct inlining associated with it. That
9985 -- would not only be inefficient but would also result in the
9986 -- backend doing cross-unit inlining in cases where it was
9987 -- definitely inappropriate to do so.
9989 -- However, a simple Comes_From_Source test is insufficient, since
9990 -- we do want to allow inlining of generic instances which also do
9991 -- not come from source. We also need to recognize specs generated
9992 -- by the front-end for bodies that carry the pragma. Finally,
9993 -- predefined operators do not come from source but are not
9994 -- inlineable either.
9996 elsif Is_Generic_Instance
(Subp
)
9997 or else Parent_Kind
(Parent
(Subp
)) = N_Subprogram_Declaration
10001 elsif not Comes_From_Source
(Subp
)
10002 and then Scope
(Subp
) /= Standard_Standard
10008 -- The referenced entity must either be the enclosing entity, or
10009 -- an entity declared within the current open scope.
10011 if Present
(Scope
(Subp
))
10012 and then Scope
(Subp
) /= Current_Scope
10013 and then Subp
/= Current_Scope
10016 ("argument of% must be entity in current scope", Assoc
);
10019 -- Processing for procedure, operator or function. If subprogram
10020 -- is aliased (as for an instance) indicate that the renamed
10021 -- entity (if declared in the same unit) is inlined.
10022 -- If this is the anonymous subprogram created for a subprogram
10023 -- instance, the inlining applies to it directly. Otherwise we
10024 -- retrieve it as the alias of the visible subprogram instance.
10026 if Is_Subprogram
(Subp
) then
10028 -- Ensure that pragma Inline_Always is associated with the
10029 -- initial declaration of the subprogram.
10031 Check_Inline_Always_Placement
(Subp
);
10033 if Is_Wrapper_Package
(Scope
(Subp
)) then
10034 Inner_Subp
:= Subp
;
10036 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
10039 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
10040 Set_Inline_Flags
(Inner_Subp
);
10042 if Present
(Parent
(Inner_Subp
)) then
10043 Decl
:= Parent
(Parent
(Inner_Subp
));
10048 if Nkind
(Decl
) = N_Subprogram_Declaration
10049 and then Present
(Corresponding_Body
(Decl
))
10051 Set_Inline_Flags
(Corresponding_Body
(Decl
));
10053 elsif Is_Generic_Instance
(Subp
)
10054 and then Comes_From_Source
(Subp
)
10056 -- Indicate that the body needs to be created for
10057 -- inlining subsequent calls. The instantiation node
10058 -- follows the declaration of the wrapper package
10059 -- created for it. The subprogram that requires the
10060 -- body is the anonymous one in the wrapper package.
10062 if Scope
(Subp
) /= Standard_Standard
10064 Need_Subprogram_Instance_Body
10065 (Next
(Unit_Declaration_Node
10066 (Scope
(Alias
(Subp
)))), Subp
)
10071 -- Inline is a program unit pragma (RM 10.1.5) and cannot
10072 -- appear in a formal part to apply to a formal subprogram.
10073 -- Do not apply check within an instance or a formal package
10074 -- the test will have been applied to the original generic.
10076 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
10077 and then In_Same_List
(Decl
, N
)
10078 and then not In_Instance
10081 ("Inline cannot apply to a formal subprogram", N
);
10087 -- For a generic subprogram set flag as well, for use at the point
10088 -- of instantiation, to determine whether the body should be
10091 elsif Is_Generic_Subprogram
(Subp
) then
10092 Set_Inline_Flags
(Subp
);
10095 -- Literals are by definition inlined
10097 elsif Kind
= E_Enumeration_Literal
then
10100 -- Anything else is an error
10104 ("expect subprogram name for pragma%", Assoc
);
10108 ----------------------
10109 -- Set_Inline_Flags --
10110 ----------------------
10112 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
10114 -- First set the Has_Pragma_XXX flags and issue the appropriate
10115 -- errors and warnings for suspicious combinations.
10117 if Prag_Id
= Pragma_No_Inline
then
10118 if Has_Pragma_Inline_Always
(Subp
) then
10120 ("Inline_Always and No_Inline are mutually exclusive", N
);
10121 elsif Has_Pragma_Inline
(Subp
) then
10123 ("Inline and No_Inline both specified for& ??",
10124 N
, Entity
(Subp_Id
));
10127 Set_Has_Pragma_No_Inline
(Subp
);
10129 if Prag_Id
= Pragma_Inline_Always
then
10130 if Has_Pragma_No_Inline
(Subp
) then
10132 ("Inline_Always and No_Inline are mutually exclusive",
10136 Set_Has_Pragma_Inline_Always
(Subp
);
10138 if Has_Pragma_No_Inline
(Subp
) then
10140 ("Inline and No_Inline both specified for& ??",
10141 N
, Entity
(Subp_Id
));
10145 Set_Has_Pragma_Inline
(Subp
);
10148 -- Then adjust the Is_Inlined flag. It can never be set if the
10149 -- subprogram is subject to pragma No_Inline.
10153 Set_Is_Inlined
(Subp
, False);
10159 if not Has_Pragma_No_Inline
(Subp
) then
10160 Set_Is_Inlined
(Subp
, True);
10164 -- A pragma that applies to a Ghost entity becomes Ghost for the
10165 -- purposes of legality checks and removal of ignored Ghost code.
10167 Mark_Ghost_Pragma
(N
, Subp
);
10169 -- Capture the entity of the first Ghost subprogram being
10170 -- processed for error detection purposes.
10172 if Is_Ghost_Entity
(Subp
) then
10173 if No
(Ghost_Id
) then
10177 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
10178 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
10180 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
10181 Ghost_Error_Posted
:= True;
10183 Error_Msg_Name_1
:= Pname
;
10185 ("pragma % cannot mention ghost and non-ghost subprograms",
10188 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
10189 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
10191 Error_Msg_Sloc
:= Sloc
(Subp
);
10192 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
10194 end Set_Inline_Flags
;
10196 -- Start of processing for Process_Inline
10199 -- An inlined subprogram may grant access to its private enclosing
10200 -- context depending on the placement of its body. From elaboration
10201 -- point of view, the flow of execution may enter this private
10202 -- context, and then reach an external unit, thus producing a
10203 -- dependency on that external unit. For such a path to be properly
10204 -- discovered and encoded in the ALI file of the main unit, let the
10205 -- ABE mechanism process the body of the main unit, and encode all
10206 -- relevant invocation constructs and the relations between them.
10208 Mark_Save_Invocation_Graph_Of_Body
;
10210 Check_No_Identifiers
;
10211 Check_At_Least_N_Arguments
(1);
10213 if Status
= Enabled
then
10214 Inline_Processing_Required
:= True;
10218 while Present
(Assoc
) loop
10219 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
10223 if Is_Entity_Name
(Subp_Id
) then
10224 Subp
:= Entity
(Subp_Id
);
10226 if Subp
= Any_Id
then
10228 -- If previous error, avoid cascaded errors
10230 Check_Error_Detected
;
10234 -- Check for RM 13.1(9.2/4): If a [...] aspect_specification
10235 -- is given that directly specifies an aspect of an entity,
10236 -- then it is illegal to give another [...]
10237 -- aspect_specification that directly specifies the same
10238 -- aspect of the entity.
10239 -- We only check Subp directly as per "directly specifies"
10240 -- above and because the case of pragma Inline is really
10241 -- special given its pre aspect usage.
10243 Check_Duplicate_Pragma
(Subp
);
10244 Record_Rep_Item
(Subp
, N
);
10246 Make_Inline
(Subp
);
10248 -- For the pragma case, climb homonym chain. This is
10249 -- what implements allowing the pragma in the renaming
10250 -- case, with the result applying to the ancestors, and
10251 -- also allows Inline to apply to all previous homonyms.
10253 if not From_Aspect_Specification
(N
) then
10254 while Present
(Homonym
(Subp
))
10255 and then Scope
(Homonym
(Subp
)) = Current_Scope
10257 Subp
:= Homonym
(Subp
);
10258 Make_Inline
(Subp
);
10264 if not Applies
then
10265 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
10271 -- If the context is a package declaration, the pragma indicates
10272 -- that inlining will require the presence of the corresponding
10273 -- body. (this may be further refined).
10276 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
10277 N_Package_Declaration
10279 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
10281 end Process_Inline
;
10283 ----------------------------
10284 -- Process_Interface_Name --
10285 ----------------------------
10287 procedure Process_Interface_Name
10288 (Subprogram_Def
: Entity_Id
;
10290 Link_Arg
: Node_Id
;
10294 Link_Nam
: Node_Id
;
10295 String_Val
: String_Id
;
10297 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
10298 -- SN is a string literal node for an interface name. This routine
10299 -- performs some minimal checks that the name is reasonable. In
10300 -- particular that no spaces or other obviously incorrect characters
10301 -- appear. This is only a warning, since any characters are allowed.
10303 ----------------------------------
10304 -- Check_Form_Of_Interface_Name --
10305 ----------------------------------
10307 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
10308 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
10309 SL
: constant Nat
:= String_Length
(S
);
10314 Error_Msg_N
("interface name cannot be null string", SN
);
10317 for J
in 1 .. SL
loop
10318 C
:= Get_String_Char
(S
, J
);
10320 -- Look for dubious character and issue unconditional warning.
10321 -- Definitely dubious if not in character range.
10323 if not In_Character_Range
(C
)
10325 -- Commas, spaces and (back)slashes are dubious
10327 or else Get_Character
(C
) = ','
10328 or else Get_Character
(C
) = '\'
10329 or else Get_Character
(C
) = ' '
10330 or else Get_Character
(C
) = '/'
10333 ("??interface name contains illegal character",
10334 Sloc
(SN
) + Source_Ptr
(J
));
10337 end Check_Form_Of_Interface_Name
;
10339 -- Start of processing for Process_Interface_Name
10342 -- If we are looking at a pragma that comes from an aspect then it
10343 -- needs to have its corresponding aspect argument expressions
10344 -- analyzed in addition to the generated pragma so that aspects
10345 -- within generic units get properly resolved.
10347 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
10349 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
10357 -- Obtain all interfacing aspects used to construct the pragma
10359 Get_Interfacing_Aspects
10360 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
10362 -- Analyze the expression of aspect External_Name
10364 if Present
(EN
) then
10365 Analyze
(Expression
(EN
));
10368 -- Analyze the expressio of aspect Link_Name
10370 if Present
(LN
) then
10371 Analyze
(Expression
(LN
));
10376 if No
(Link_Arg
) then
10377 if No
(Ext_Arg
) then
10380 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10382 Link_Nam
:= Expression
(Ext_Arg
);
10385 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10386 Ext_Nam
:= Expression
(Ext_Arg
);
10391 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10392 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10393 Ext_Nam
:= Expression
(Ext_Arg
);
10394 Link_Nam
:= Expression
(Link_Arg
);
10397 -- Check expressions for external name and link name are static
10399 if Present
(Ext_Nam
) then
10400 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10401 Check_Form_Of_Interface_Name
(Ext_Nam
);
10403 -- Verify that external name is not the name of a local entity,
10404 -- which would hide the imported one and could lead to run-time
10405 -- surprises. The problem can only arise for entities declared in
10406 -- a package body (otherwise the external name is fully qualified
10407 -- and will not conflict).
10415 if Prag_Id
= Pragma_Import
then
10416 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10417 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10419 if Nam
/= Chars
(Subprogram_Def
)
10420 and then Present
(E
)
10421 and then not Is_Overloadable
(E
)
10422 and then Is_Immediately_Visible
(E
)
10423 and then not Is_Imported
(E
)
10424 and then Ekind
(Scope
(E
)) = E_Package
10427 while Present
(Par
) loop
10428 if Nkind
(Par
) = N_Package_Body
then
10429 Error_Msg_Sloc
:= Sloc
(E
);
10431 ("imported entity is hidden by & declared#",
10436 Par
:= Parent
(Par
);
10443 if Present
(Link_Nam
) then
10444 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10445 Check_Form_Of_Interface_Name
(Link_Nam
);
10448 -- If there is no link name, just set the external name
10450 if No
(Link_Nam
) then
10451 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10453 -- For the Link_Name case, the given literal is preceded by an
10454 -- asterisk, which indicates to GCC that the given name should be
10455 -- taken literally, and in particular that no prepending of
10456 -- underlines should occur, even in systems where this is the
10461 Store_String_Char
(Get_Char_Code
('*'));
10462 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10463 Store_String_Chars
(String_Val
);
10465 Make_String_Literal
(Sloc
(Link_Nam
),
10466 Strval
=> End_String
);
10469 -- Set the interface name. If the entity is a generic instance, use
10470 -- its alias, which is the callable entity.
10472 if Is_Generic_Instance
(Subprogram_Def
) then
10473 Set_Encoded_Interface_Name
10474 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10476 Set_Encoded_Interface_Name
10477 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10480 Check_Duplicated_Export_Name
(Link_Nam
);
10481 end Process_Interface_Name
;
10483 -----------------------------------------
10484 -- Process_Interrupt_Or_Attach_Handler --
10485 -----------------------------------------
10487 procedure Process_Interrupt_Or_Attach_Handler
is
10488 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10489 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10492 -- A pragma that applies to a Ghost entity becomes Ghost for the
10493 -- purposes of legality checks and removal of ignored Ghost code.
10495 Mark_Ghost_Pragma
(N
, Handler
);
10496 Set_Is_Interrupt_Handler
(Handler
);
10498 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10500 Record_Rep_Item
(Prot_Typ
, N
);
10502 -- Chain the pragma on the contract for completeness
10504 Add_Contract_Item
(N
, Handler
);
10505 end Process_Interrupt_Or_Attach_Handler
;
10507 --------------------------------------------------
10508 -- Process_Restrictions_Or_Restriction_Warnings --
10509 --------------------------------------------------
10511 -- Note: some of the simple identifier cases were handled in par-prag,
10512 -- but it is harmless (and more straightforward) to simply handle all
10513 -- cases here, even if it means we repeat a bit of work in some cases.
10515 procedure Process_Restrictions_Or_Restriction_Warnings
10519 R_Id
: Restriction_Id
;
10524 procedure Process_No_Specification_of_Aspect
;
10525 -- Process the No_Specification_of_Aspect restriction
10527 procedure Process_No_Use_Of_Attribute
;
10528 -- Process the No_Use_Of_Attribute restriction
10530 ----------------------------------------
10531 -- Process_No_Specification_of_Aspect --
10532 ----------------------------------------
10534 procedure Process_No_Specification_of_Aspect
is
10535 Name
: constant Name_Id
:= Chars
(Expr
);
10537 if Nkind
(Expr
) = N_Identifier
10538 and then Is_Aspect_Id
(Name
)
10540 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10542 Bad_Aspect
(Expr
, Name
, Warn
=> True);
10546 end Process_No_Specification_of_Aspect
;
10548 ---------------------------------
10549 -- Process_No_Use_Of_Attribute --
10550 ---------------------------------
10552 procedure Process_No_Use_Of_Attribute
is
10553 Name
: constant Name_Id
:= Chars
(Expr
);
10555 if Nkind
(Expr
) = N_Identifier
10556 and then Is_Attribute_Name
(Name
)
10558 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10560 Bad_Attribute
(Expr
, Name
, Warn
=> True);
10563 end Process_No_Use_Of_Attribute
;
10565 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
10568 -- Ignore all Restrictions pragmas in CodePeer mode
10570 if CodePeer_Mode
then
10574 Check_Ada_83_Warning
;
10575 Check_At_Least_N_Arguments
(1);
10576 Check_Valid_Configuration_Pragma
;
10579 while Present
(Arg
) loop
10581 Expr
:= Get_Pragma_Arg
(Arg
);
10583 -- Case of no restriction identifier present
10585 if Id
= No_Name
then
10586 if Nkind
(Expr
) /= N_Identifier
then
10588 ("invalid form for restriction", Arg
);
10593 (Process_Restriction_Synonyms
(Expr
));
10595 if R_Id
not in All_Boolean_Restrictions
then
10596 Error_Msg_Name_1
:= Pname
;
10598 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10600 -- Check for possible misspelling
10602 for J
in All_Restrictions
loop
10604 Rnm
: constant String := Restriction_Id
'Image (J
);
10607 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10608 Name_Len
:= Rnm
'Length;
10609 Set_Casing
(All_Lower_Case
);
10611 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10614 (Source_Index
(Current_Sem_Unit
)));
10615 Error_Msg_String
(1 .. Rnm
'Length) :=
10616 Name_Buffer
(1 .. Name_Len
);
10617 Error_Msg_Strlen
:= Rnm
'Length;
10618 Error_Msg_N
-- CODEFIX
10619 ("\possible misspelling of ""~""",
10620 Get_Pragma_Arg
(Arg
));
10629 if Implementation_Restriction
(R_Id
) then
10630 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10633 -- Special processing for No_Elaboration_Code restriction
10635 if R_Id
= No_Elaboration_Code
then
10637 -- Restriction is only recognized within a configuration
10638 -- pragma file, or within a unit of the main extended
10639 -- program. Note: the test for Main_Unit is needed to
10640 -- properly include the case of configuration pragma files.
10642 if not (Current_Sem_Unit
= Main_Unit
10643 or else In_Extended_Main_Source_Unit
(N
))
10647 -- Don't allow in a subunit unless already specified in
10650 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10651 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10652 and then not Restriction_Active
(No_Elaboration_Code
)
10655 ("invalid specification of ""No_Elaboration_Code""",
10658 ("\restriction cannot be specified in a subunit", N
);
10660 ("\unless also specified in body or spec", N
);
10663 -- If we accept a No_Elaboration_Code restriction, then it
10664 -- needs to be added to the configuration restriction set so
10665 -- that we get proper application to other units in the main
10666 -- extended source as required.
10669 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10672 -- Special processing for No_Dynamic_Accessibility_Checks to
10673 -- disallow exclusive specification in a body or subunit.
10675 elsif R_Id
= No_Dynamic_Accessibility_Checks
10676 -- Check if the restriction is within configuration pragma
10677 -- in a similar way to No_Elaboration_Code.
10679 and then not (Current_Sem_Unit
= Main_Unit
10680 or else In_Extended_Main_Source_Unit
(N
))
10682 and then Nkind
(Unit
(Parent
(N
))) = N_Compilation_Unit
10684 and then (Nkind
(Unit
(Parent
(N
))) = N_Package_Body
10685 or else Nkind
(Unit
(Parent
(N
))) = N_Subunit
)
10687 and then not Restriction_Active
10688 (No_Dynamic_Accessibility_Checks
)
10691 ("invalid specification of " &
10692 """No_Dynamic_Accessibility_Checks""", N
);
10694 if Nkind
(Unit
(Parent
(N
))) = N_Package_Body
then
10696 ("\restriction cannot be specified in a package " &
10699 elsif Nkind
(Unit
(Parent
(N
))) = N_Subunit
then
10701 ("\restriction cannot be specified in a subunit", N
);
10705 ("\unless also specified in spec", N
);
10707 -- Special processing for No_Tasking restriction (not just a
10708 -- warning) when it appears as a configuration pragma.
10710 elsif R_Id
= No_Tasking
10711 and then No
(Cunit
(Main_Unit
))
10714 Set_Global_No_Tasking
;
10717 Set_Restriction
(R_Id
, N
, Warn
);
10719 if R_Id
= No_Dynamic_CPU_Assignment
10720 or else R_Id
= No_Tasks_Unassigned_To_CPU
10722 -- These imply No_Dependence =>
10723 -- "System.Multiprocessors.Dispatching_Domains".
10724 -- This is not strictly what the AI says, but it eliminates
10725 -- the need for run-time checks, which are undesirable in
10728 Set_Restriction_No_Dependence
10730 (Sel_Comp
("system", "multiprocessors", Loc
),
10731 "dispatching_domains"),
10735 if R_Id
= No_Tasks_Unassigned_To_CPU
then
10736 -- Likewise, imply No_Dynamic_CPU_Assignment
10738 Set_Restriction
(No_Dynamic_CPU_Assignment
, N
, Warn
);
10741 -- Check for obsolescent restrictions in Ada 2005 mode
10744 and then Ada_Version
>= Ada_2005
10745 and then (R_Id
= No_Asynchronous_Control
10747 R_Id
= No_Unchecked_Deallocation
10749 R_Id
= No_Unchecked_Conversion
)
10751 Check_Restriction
(No_Obsolescent_Features
, N
);
10754 -- A very special case that must be processed here: pragma
10755 -- Restrictions (No_Exceptions) turns off all run-time
10756 -- checking. This is a bit dubious in terms of the formal
10757 -- language definition, but it is what is intended by RM
10758 -- H.4(12). Restriction_Warnings never affects generated code
10759 -- so this is done only in the real restriction case.
10761 -- Atomic_Synchronization is not a real check, so it is not
10762 -- affected by this processing).
10764 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10765 -- run-time checks in CodePeer and GNATprove modes: we want to
10766 -- generate checks for analysis purposes, as set respectively
10767 -- by -gnatC and -gnatd.F
10770 and then not (CodePeer_Mode
or GNATprove_Mode
)
10771 and then R_Id
= No_Exceptions
10773 for J
in Scope_Suppress
.Suppress
'Range loop
10774 if J
/= Atomic_Synchronization
then
10775 Scope_Suppress
.Suppress
(J
) := True;
10780 -- Case of No_Dependence => unit-name. Note that the parser
10781 -- already made the necessary entry in the No_Dependence table.
10783 elsif Id
= Name_No_Dependence
then
10784 if not OK_No_Dependence_Unit_Name
(Expr
) then
10788 -- Case of No_Specification_Of_Aspect => aspect-identifier
10790 elsif Id
= Name_No_Specification_Of_Aspect
then
10791 Process_No_Specification_of_Aspect
;
10793 -- Case of No_Use_Of_Attribute => attribute-identifier
10795 elsif Id
= Name_No_Use_Of_Attribute
then
10796 Process_No_Use_Of_Attribute
;
10798 -- Case of No_Use_Of_Entity => fully-qualified-name
10800 elsif Id
= Name_No_Use_Of_Entity
then
10802 -- Restriction is only recognized within a configuration
10803 -- pragma file, or within a unit of the main extended
10804 -- program. Note: the test for Main_Unit is needed to
10805 -- properly include the case of configuration pragma files.
10807 if Current_Sem_Unit
= Main_Unit
10808 or else In_Extended_Main_Source_Unit
(N
)
10810 if not OK_No_Dependence_Unit_Name
(Expr
) then
10811 Error_Msg_N
("wrong form for entity name", Expr
);
10813 Set_Restriction_No_Use_Of_Entity
10814 (Expr
, Warn
, No_Profile
);
10818 -- Case of No_Use_Of_Pragma => pragma-identifier
10820 elsif Id
= Name_No_Use_Of_Pragma
then
10821 if Nkind
(Expr
) /= N_Identifier
10822 or else not Is_Pragma_Name
(Chars
(Expr
))
10824 Error_Msg_N
("unknown pragma name??", Expr
);
10826 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10829 -- All other cases of restriction identifier present
10832 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10834 if R_Id
not in All_Parameter_Restrictions
then
10836 ("invalid restriction parameter identifier", Arg
);
10839 Analyze_And_Resolve
(Expr
, Any_Integer
);
10841 if not Is_OK_Static_Expression
(Expr
) then
10842 Flag_Non_Static_Expr
10843 ("value must be static expression!", Expr
);
10846 elsif not Is_Integer_Type
(Etype
(Expr
))
10847 or else Expr_Value
(Expr
) < 0
10850 ("value must be non-negative integer", Arg
);
10853 -- Restriction pragma is active
10855 Val
:= Expr_Value
(Expr
);
10857 if not UI_Is_In_Int_Range
(Val
) then
10859 ("pragma ignored, value too large??", Arg
);
10862 Set_Restriction
(R_Id
, N
, Warn
, Integer (UI_To_Int
(Val
)));
10867 end Process_Restrictions_Or_Restriction_Warnings
;
10869 ---------------------------------
10870 -- Process_Suppress_Unsuppress --
10871 ---------------------------------
10873 -- Note: this procedure makes entries in the check suppress data
10874 -- structures managed by Sem. See spec of package Sem for full
10875 -- details on how we handle recording of check suppression.
10877 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10882 In_Package_Spec
: constant Boolean :=
10883 Is_Package_Or_Generic_Package
(Current_Scope
)
10884 and then not In_Package_Body
(Current_Scope
);
10886 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10887 -- Used to suppress a single check on the given entity
10889 --------------------------------
10890 -- Suppress_Unsuppress_Echeck --
10891 --------------------------------
10893 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10895 -- Check for error of trying to set atomic synchronization for
10896 -- a non-atomic variable.
10898 if C
= Atomic_Synchronization
10899 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10902 ("pragma & requires atomic type or variable",
10903 Pragma_Identifier
(Original_Node
(N
)));
10906 Set_Checks_May_Be_Suppressed
(E
);
10908 if In_Package_Spec
then
10909 Push_Global_Suppress_Stack_Entry
10912 Suppress
=> Suppress_Case
);
10914 Push_Local_Suppress_Stack_Entry
10917 Suppress
=> Suppress_Case
);
10920 -- If this is a first subtype, and the base type is distinct,
10921 -- then also set the suppress flags on the base type.
10923 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10924 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10926 end Suppress_Unsuppress_Echeck
;
10928 -- Start of processing for Process_Suppress_Unsuppress
10931 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10932 -- on user code: we want to generate checks for analysis purposes, as
10933 -- set respectively by -gnatC and -gnatd.F
10935 if Comes_From_Source
(N
)
10936 and then (CodePeer_Mode
or GNATprove_Mode
)
10941 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10942 -- declarative part or a package spec (RM 11.5(5)).
10944 if not Is_Configuration_Pragma
then
10945 Check_Is_In_Decl_Part_Or_Package_Spec
;
10948 Check_At_Least_N_Arguments
(1);
10949 Check_At_Most_N_Arguments
(2);
10950 Check_No_Identifier
(Arg1
);
10951 Check_Arg_Is_Identifier
(Arg1
);
10953 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10955 if C
= No_Check_Id
then
10957 ("argument of pragma% is not valid check name", Arg1
);
10960 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10962 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10964 ("Suppress of Elaboration_Check ignored in SPARK??",
10965 "\elaboration checking rules are statically enforced "
10966 & "(SPARK RM 7.7)", Arg1
);
10969 -- One-argument case
10971 if Arg_Count
= 1 then
10973 -- Make an entry in the local scope suppress table. This is the
10974 -- table that directly shows the current value of the scope
10975 -- suppress check for any check id value.
10977 if C
= All_Checks
then
10979 -- For All_Checks, we set all specific predefined checks with
10980 -- the exception of Elaboration_Check, which is handled
10981 -- specially because of not wanting All_Checks to have the
10982 -- effect of deactivating static elaboration order processing.
10983 -- Atomic_Synchronization is also not affected, since this is
10984 -- not a real check.
10986 for J
in Scope_Suppress
.Suppress
'Range loop
10987 if J
/= Elaboration_Check
10989 J
/= Atomic_Synchronization
10991 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10995 -- If not All_Checks, and predefined check, then set appropriate
10996 -- scope entry. Note that we will set Elaboration_Check if this
10997 -- is explicitly specified. Atomic_Synchronization is allowed
10998 -- only if internally generated and entity is atomic.
11000 elsif C
in Predefined_Check_Id
11001 and then (not Comes_From_Source
(N
)
11002 or else C
/= Atomic_Synchronization
)
11004 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
11007 -- Also push an entry in the local suppress stack
11009 Push_Local_Suppress_Stack_Entry
11012 Suppress
=> Suppress_Case
);
11014 -- Case of two arguments present, where the check is suppressed for
11015 -- a specified entity (given as the second argument of the pragma)
11018 -- This is obsolescent in Ada 2005 mode
11020 if Ada_Version
>= Ada_2005
then
11021 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
11024 Check_Optional_Identifier
(Arg2
, Name_On
);
11025 E_Id
:= Get_Pragma_Arg
(Arg2
);
11028 if not Is_Entity_Name
(E_Id
) then
11030 ("second argument of pragma% must be entity name", Arg2
);
11033 E
:= Entity
(E_Id
);
11039 -- A pragma that applies to a Ghost entity becomes Ghost for the
11040 -- purposes of legality checks and removal of ignored Ghost code.
11042 Mark_Ghost_Pragma
(N
, E
);
11044 -- Enforce RM 11.5(7) which requires that for a pragma that
11045 -- appears within a package spec, the named entity must be
11046 -- within the package spec. We allow the package name itself
11047 -- to be mentioned since that makes sense, although it is not
11048 -- strictly allowed by 11.5(7).
11051 and then E
/= Current_Scope
11052 and then Scope
(E
) /= Current_Scope
11055 ("entity in pragma% is not in package spec (RM 11.5(7))",
11059 -- Loop through homonyms. As noted below, in the case of a package
11060 -- spec, only homonyms within the package spec are considered.
11063 Suppress_Unsuppress_Echeck
(E
, C
);
11065 if Is_Generic_Instance
(E
)
11066 and then Is_Subprogram
(E
)
11067 and then Present
(Alias
(E
))
11069 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
11072 -- Move to next homonym if not aspect spec case
11074 exit when From_Aspect_Specification
(N
);
11078 -- If we are within a package specification, the pragma only
11079 -- applies to homonyms in the same scope.
11081 exit when In_Package_Spec
11082 and then Scope
(E
) /= Current_Scope
;
11085 end Process_Suppress_Unsuppress
;
11087 -------------------------------
11088 -- Record_Independence_Check --
11089 -------------------------------
11091 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
11092 pragma Unreferenced
(N
, E
);
11094 -- For GCC back ends the validation is done a priori. This code is
11095 -- dead, but might be useful in the future.
11097 -- if not AAMP_On_Target then
11101 -- Independence_Checks.Append ((N, E));
11104 end Record_Independence_Check
;
11110 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
11112 if Is_Imported
(E
) then
11114 ("cannot export entity& that was previously imported", Arg
);
11116 elsif Present
(Address_Clause
(E
))
11117 and then not Relaxed_RM_Semantics
11120 ("cannot export entity& that has an address clause", Arg
);
11123 Set_Is_Exported
(E
);
11125 -- Generate a reference for entity explicitly, because the
11126 -- identifier may be overloaded and name resolution will not
11129 Generate_Reference
(E
, Arg
);
11131 -- Deal with exporting non-library level entity
11133 if not Is_Library_Level_Entity
(E
) then
11135 -- Not allowed at all for subprograms
11137 if Is_Subprogram
(E
) then
11138 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
11140 -- Otherwise set public and statically allocated
11144 Set_Is_Statically_Allocated
(E
);
11146 -- Warn if the corresponding W flag is set
11148 if Warn_On_Export_Import
11150 -- Only do this for something that was in the source. Not
11151 -- clear if this can be False now (there used for sure to be
11152 -- cases on some systems where it was False), but anyway the
11153 -- test is harmless if not needed, so it is retained.
11155 and then Comes_From_Source
(Arg
)
11158 ("?x?& has been made static as a result of Export",
11161 ("\?x?this usage is non-standard and non-portable",
11167 if Warn_On_Export_Import
and Inside_A_Generic
then
11169 ("all instances of& will have the same external name?x?",
11174 ----------------------------------------------
11175 -- Set_Extended_Import_Export_External_Name --
11176 ----------------------------------------------
11178 procedure Set_Extended_Import_Export_External_Name
11179 (Internal_Ent
: Entity_Id
;
11180 Arg_External
: Node_Id
)
11182 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
11183 New_Name
: Node_Id
;
11186 if No
(Arg_External
) then
11190 Check_Arg_Is_External_Name
(Arg_External
);
11192 if Nkind
(Arg_External
) = N_String_Literal
then
11193 if String_Length
(Strval
(Arg_External
)) = 0 then
11196 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
11199 elsif Nkind
(Arg_External
) = N_Identifier
then
11200 New_Name
:= Get_Default_External_Name
(Arg_External
);
11202 -- Check_Arg_Is_External_Name should let through only identifiers and
11203 -- string literals or static string expressions (which are folded to
11204 -- string literals).
11207 raise Program_Error
;
11210 -- If we already have an external name set (by a prior normal Import
11211 -- or Export pragma), then the external names must match
11213 if Present
(Interface_Name
(Internal_Ent
)) then
11215 -- Ignore mismatching names in CodePeer mode, to support some
11216 -- old compilers which would export the same procedure under
11217 -- different names, e.g:
11219 -- pragma Export_Procedure (P, "a");
11220 -- pragma Export_Procedure (P, "b");
11222 if CodePeer_Mode
then
11226 Check_Matching_Internal_Names
: declare
11227 S1
: constant String_Id
:= Strval
(Old_Name
);
11228 S2
: constant String_Id
:= Strval
(New_Name
);
11230 procedure Mismatch
;
11231 pragma No_Return
(Mismatch
);
11232 -- Called if names do not match
11238 procedure Mismatch
is
11240 Error_Msg_Sloc
:= Sloc
(Old_Name
);
11242 ("external name does not match that given #",
11246 -- Start of processing for Check_Matching_Internal_Names
11249 if String_Length
(S1
) /= String_Length
(S2
) then
11253 for J
in 1 .. String_Length
(S1
) loop
11254 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
11259 end Check_Matching_Internal_Names
;
11261 -- Otherwise set the given name
11264 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
11265 Check_Duplicated_Export_Name
(New_Name
);
11267 end Set_Extended_Import_Export_External_Name
;
11273 procedure Set_Imported
(E
: Entity_Id
) is
11275 -- Error message if already imported or exported
11277 if Is_Exported
(E
) or else Is_Imported
(E
) then
11279 -- Error if being set Exported twice
11281 if Is_Exported
(E
) then
11282 Error_Msg_NE
("entity& was previously exported", N
, E
);
11284 -- Ignore error in CodePeer mode where we treat all imported
11285 -- subprograms as unknown.
11287 elsif CodePeer_Mode
then
11290 -- OK if Import/Interface case
11292 elsif Import_Interface_Present
(N
) then
11295 -- Error if being set Imported twice
11298 Error_Msg_NE
("entity& was previously imported", N
, E
);
11301 Error_Msg_Name_1
:= Pname
;
11303 ("\(pragma% applies to all previous entities)", N
);
11305 Error_Msg_Sloc
:= Sloc
(E
);
11306 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
11308 -- Here if not previously imported or exported, OK to import
11311 Set_Is_Imported
(E
);
11313 -- For subprogram, set Import_Pragma field
11315 if Is_Subprogram
(E
) then
11316 Set_Import_Pragma
(E
, N
);
11319 -- If the entity is an object that is not at the library level,
11320 -- then it is statically allocated. We do not worry about objects
11321 -- with address clauses in this context since they are not really
11322 -- imported in the linker sense.
11325 and then not Is_Library_Level_Entity
(E
)
11326 and then No
(Address_Clause
(E
))
11328 Set_Is_Statically_Allocated
(E
);
11335 -------------------------
11336 -- Set_Mechanism_Value --
11337 -------------------------
11339 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11340 -- analyzed, since it is semantic nonsense), so we get it in the exact
11341 -- form created by the parser.
11343 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
11344 procedure Bad_Mechanism
;
11345 pragma No_Return
(Bad_Mechanism
);
11346 -- Signal bad mechanism name
11348 -------------------
11349 -- Bad_Mechanism --
11350 -------------------
11352 procedure Bad_Mechanism
is
11354 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
11357 -- Start of processing for Set_Mechanism_Value
11360 if Mechanism
(Ent
) /= Default_Mechanism
then
11362 ("mechanism for & has already been set", Mech_Name
, Ent
);
11365 -- MECHANISM_NAME ::= value | reference
11367 if Nkind
(Mech_Name
) = N_Identifier
then
11368 if Chars
(Mech_Name
) = Name_Value
then
11369 Set_Mechanism
(Ent
, By_Copy
);
11372 elsif Chars
(Mech_Name
) = Name_Reference
then
11373 Set_Mechanism
(Ent
, By_Reference
);
11376 elsif Chars
(Mech_Name
) = Name_Copy
then
11378 ("bad mechanism name, Value assumed", Mech_Name
);
11387 end Set_Mechanism_Value
;
11389 --------------------------
11390 -- Set_Rational_Profile --
11391 --------------------------
11393 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11394 -- extension to the semantics of renaming declarations.
11396 procedure Set_Rational_Profile
is
11398 Implicit_Packing
:= True;
11399 Overriding_Renamings
:= True;
11400 Use_VADS_Size
:= True;
11401 end Set_Rational_Profile
;
11403 ---------------------------
11404 -- Set_Ravenscar_Profile --
11405 ---------------------------
11407 -- The tasks to be done here are
11409 -- Set required policies
11411 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11412 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11413 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11414 -- (For GNAT_Ravenscar_EDF profile)
11415 -- pragma Locking_Policy (Ceiling_Locking)
11417 -- Set Detect_Blocking mode
11419 -- Set required restrictions (see System.Rident for detailed list)
11421 -- Set the No_Dependence rules
11422 -- No_Dependence => Ada.Asynchronous_Task_Control
11423 -- No_Dependence => Ada.Calendar
11424 -- No_Dependence => Ada.Execution_Time.Group_Budget
11425 -- No_Dependence => Ada.Execution_Time.Timers
11426 -- No_Dependence => Ada.Task_Attributes
11427 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11429 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11430 procedure Set_Error_Msg_To_Profile_Name
;
11431 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11434 -----------------------------------
11435 -- Set_Error_Msg_To_Profile_Name --
11436 -----------------------------------
11438 procedure Set_Error_Msg_To_Profile_Name
is
11439 Prof_Nam
: constant Node_Id
:=
11441 (First
(Pragma_Argument_Associations
(N
)));
11444 Get_Name_String
(Chars
(Prof_Nam
));
11445 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11446 Error_Msg_Strlen
:= Name_Len
;
11447 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11448 end Set_Error_Msg_To_Profile_Name
;
11450 Profile_Dispatching_Policy
: Character;
11452 -- Start of processing for Set_Ravenscar_Profile
11455 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11457 if Profile
= GNAT_Ravenscar_EDF
then
11458 Profile_Dispatching_Policy
:= 'E';
11460 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11463 Profile_Dispatching_Policy
:= 'F';
11466 if Task_Dispatching_Policy
/= ' '
11467 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11469 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11470 Set_Error_Msg_To_Profile_Name
;
11471 Error_Pragma
("Profile (~) incompatible with policy#");
11473 -- Set the FIFO_Within_Priorities policy, but always preserve
11474 -- System_Location since we like the error message with the run time
11478 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11480 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11481 Task_Dispatching_Policy_Sloc
:= Loc
;
11485 -- pragma Locking_Policy (Ceiling_Locking)
11487 if Locking_Policy
/= ' '
11488 and then Locking_Policy
/= 'C'
11490 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11491 Set_Error_Msg_To_Profile_Name
;
11492 Error_Pragma
("Profile (~) incompatible with policy#");
11494 -- Set the Ceiling_Locking policy, but preserve System_Location since
11495 -- we like the error message with the run time name.
11498 Locking_Policy
:= 'C';
11500 if Locking_Policy_Sloc
/= System_Location
then
11501 Locking_Policy_Sloc
:= Loc
;
11505 -- pragma Detect_Blocking
11507 Detect_Blocking
:= True;
11509 -- Set the corresponding restrictions
11511 Set_Profile_Restrictions
11512 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11514 -- Set the No_Dependence restrictions
11516 -- The following No_Dependence restrictions:
11517 -- No_Dependence => Ada.Asynchronous_Task_Control
11518 -- No_Dependence => Ada.Calendar
11519 -- No_Dependence => Ada.Task_Attributes
11520 -- are already set by previous call to Set_Profile_Restrictions.
11523 -- Set the following restrictions which were added to Ada 2005:
11524 -- No_Dependence => Ada.Execution_Time.Group_Budget
11525 -- No_Dependence => Ada.Execution_Time.Timers
11527 if Ada_Version
>= Ada_2005
then
11529 Execution_Time
: constant Node_Id
:=
11530 Sel_Comp
("ada", "execution_time", Loc
);
11531 Group_Budgets
: constant Node_Id
:=
11532 Sel_Comp
(Execution_Time
, "group_budgets");
11533 Timers
: constant Node_Id
:=
11534 Sel_Comp
(Execution_Time
, "timers");
11536 Set_Restriction_No_Dependence
11537 (Unit
=> Group_Budgets
,
11538 Warn
=> Treat_Restrictions_As_Warnings
,
11539 Profile
=> Ravenscar
);
11540 Set_Restriction_No_Dependence
11542 Warn
=> Treat_Restrictions_As_Warnings
,
11543 Profile
=> Ravenscar
);
11547 -- Set the following restriction which was added to Ada 2012 (see
11549 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11551 if Ada_Version
>= Ada_2012
then
11552 Set_Restriction_No_Dependence
11554 (Sel_Comp
("system", "multiprocessors", Loc
),
11555 "dispatching_domains"),
11556 Warn
=> Treat_Restrictions_As_Warnings
,
11557 Profile
=> Ravenscar
);
11559 -- Set the following restriction which was added to Ada 2022,
11560 -- but as a binding interpretation:
11561 -- No_Dependence => Ada.Synchronous_Barriers
11562 -- for Ravenscar (and therefore for Ravenscar variants) but not
11563 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11564 -- in Ada2012 (AI05-0174).
11566 if Profile
/= Jorvik
then
11567 Set_Restriction_No_Dependence
11568 (Sel_Comp
("ada", "synchronous_barriers", Loc
),
11569 Warn
=> Treat_Restrictions_As_Warnings
,
11570 Profile
=> Ravenscar
);
11574 end Set_Ravenscar_Profile
;
11576 -- Start of processing for Analyze_Pragma
11579 -- The following code is a defense against recursion. Not clear that
11580 -- this can happen legitimately, but perhaps some error situations can
11581 -- cause it, and we did see this recursion during testing.
11583 if Analyzed
(N
) then
11589 Check_Restriction_No_Use_Of_Pragma
(N
);
11591 if Is_Aspect_Id
(Chars
(Pragma_Identifier
(N
))) then
11592 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11593 -- no aspect_specification, attribute_definition_clause, or pragma
11595 Check_Restriction_No_Specification_Of_Aspect
(N
);
11598 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11599 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11601 if Should_Ignore_Pragma_Sem
(N
)
11602 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11603 and then Ignore_Rep_Clauses
)
11608 -- Deal with unrecognized pragma
11610 if not Is_Pragma_Name
(Pname
) then
11612 Msg_Issued
: Boolean := False;
11615 (Msg_Issued
, No_Unrecognized_Pragmas
, Pragma_Identifier
(N
));
11616 if not Msg_Issued
and then Warn_On_Unrecognized_Pragma
then
11617 Error_Msg_Name_1
:= Pname
;
11618 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11620 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11621 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11622 Error_Msg_Name_1
:= PN
;
11623 Error_Msg_N
-- CODEFIX
11624 ("\?g?possible misspelling of %!",
11625 Pragma_Identifier
(N
));
11635 -- Here to start processing for recognized pragma
11637 Pname
:= Original_Aspect_Pragma_Name
(N
);
11639 -- Capture setting of Opt.Uneval_Old
11641 case Opt
.Uneval_Old
is
11643 Set_Uneval_Old_Accept
(N
);
11649 Set_Uneval_Old_Warn
(N
);
11652 raise Program_Error
;
11655 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11656 -- is already set, indicating that we have already checked the policy
11657 -- at the right point. This happens for example in the case of a pragma
11658 -- that is derived from an Aspect.
11660 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11663 -- For a pragma that is a rewriting of another pragma, copy the
11664 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11666 elsif Is_Rewrite_Substitution
(N
)
11667 and then Nkind
(Original_Node
(N
)) = N_Pragma
11669 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11670 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11672 -- Otherwise query the applicable policy at this point
11675 Check_Applicable_Policy
(N
);
11677 -- If pragma is disabled, rewrite as NULL and skip analysis
11679 if Is_Disabled
(N
) then
11680 Rewrite
(N
, Make_Null_Statement
(Loc
));
11686 -- Mark assertion pragmas as Ghost depending on their enclosing context
11688 if Assertion_Expression_Pragma
(Prag_Id
) then
11689 Mark_Ghost_Pragma
(N
, Current_Scope
);
11692 -- Preset arguments
11701 if Present
(Pragma_Argument_Associations
(N
)) then
11702 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11703 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11705 if Present
(Arg1
) then
11706 Arg2
:= Next
(Arg1
);
11708 if Present
(Arg2
) then
11709 Arg3
:= Next
(Arg2
);
11711 if Present
(Arg3
) then
11712 Arg4
:= Next
(Arg3
);
11714 if Present
(Arg4
) then
11715 Arg5
:= Next
(Arg4
);
11722 -- An enumeration type defines the pragmas that are supported by the
11723 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11724 -- into the corresponding enumeration value for the following case.
11732 -- pragma Abort_Defer;
11734 when Pragma_Abort_Defer
=>
11736 Check_Arg_Count
(0);
11738 -- The only required semantic processing is to check the
11739 -- placement. This pragma must appear at the start of the
11740 -- statement sequence of a handled sequence of statements.
11742 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11743 or else N
/= First
(Statements
(Parent
(N
)))
11748 --------------------
11749 -- Abstract_State --
11750 --------------------
11752 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11754 -- ABSTRACT_STATE_LIST ::=
11756 -- | STATE_NAME_WITH_OPTIONS
11757 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11759 -- STATE_NAME_WITH_OPTIONS ::=
11761 -- | (STATE_NAME with OPTION_LIST)
11763 -- OPTION_LIST ::= OPTION {, OPTION}
11767 -- | NAME_VALUE_OPTION
11769 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11771 -- NAME_VALUE_OPTION ::=
11772 -- Part_Of => ABSTRACT_STATE
11773 -- | External [=> EXTERNAL_PROPERTY_LIST]
11775 -- EXTERNAL_PROPERTY_LIST ::=
11776 -- EXTERNAL_PROPERTY
11777 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11779 -- EXTERNAL_PROPERTY ::=
11780 -- Async_Readers [=> boolean_EXPRESSION]
11781 -- | Async_Writers [=> boolean_EXPRESSION]
11782 -- | Effective_Reads [=> boolean_EXPRESSION]
11783 -- | Effective_Writes [=> boolean_EXPRESSION]
11784 -- others => boolean_EXPRESSION
11786 -- STATE_NAME ::= defining_identifier
11788 -- ABSTRACT_STATE ::= name
11790 -- Characteristics:
11792 -- * Analysis - The annotation is fully analyzed immediately upon
11793 -- elaboration as it cannot forward reference entities.
11795 -- * Expansion - None.
11797 -- * Template - The annotation utilizes the generic template of the
11798 -- related package declaration.
11800 -- * Globals - The annotation cannot reference global entities.
11802 -- * Instance - The annotation is instantiated automatically when
11803 -- the related generic package is instantiated.
11805 when Pragma_Abstract_State
=> Abstract_State
: declare
11806 Missing_Parentheses
: Boolean := False;
11807 -- Flag set when a state declaration with options is not properly
11810 -- Flags used to verify the consistency of states
11812 Non_Null_Seen
: Boolean := False;
11813 Null_Seen
: Boolean := False;
11815 procedure Analyze_Abstract_State
11817 Pack_Id
: Entity_Id
);
11818 -- Verify the legality of a single state declaration. Create and
11819 -- decorate a state abstraction entity and introduce it into the
11820 -- visibility chain. Pack_Id denotes the entity or the related
11821 -- package where pragma Abstract_State appears.
11823 procedure Malformed_State_Error
(State
: Node_Id
);
11824 -- Emit an error concerning the illegal declaration of abstract
11825 -- state State. This routine diagnoses syntax errors that lead to
11826 -- a different parse tree. The error is issued regardless of the
11827 -- SPARK mode in effect.
11829 ----------------------------
11830 -- Analyze_Abstract_State --
11831 ----------------------------
11833 procedure Analyze_Abstract_State
11835 Pack_Id
: Entity_Id
)
11837 -- Flags used to verify the consistency of options
11839 AR_Seen
: Boolean := False;
11840 AW_Seen
: Boolean := False;
11841 ER_Seen
: Boolean := False;
11842 EW_Seen
: Boolean := False;
11843 External_Seen
: Boolean := False;
11844 Ghost_Seen
: Boolean := False;
11845 Others_Seen
: Boolean := False;
11846 Part_Of_Seen
: Boolean := False;
11847 Relaxed_Initialization_Seen
: Boolean := False;
11848 Synchronous_Seen
: Boolean := False;
11850 -- Flags used to store the static value of all external states'
11853 AR_Val
: Boolean := False;
11854 AW_Val
: Boolean := False;
11855 ER_Val
: Boolean := False;
11856 EW_Val
: Boolean := False;
11858 State_Id
: Entity_Id
:= Empty
;
11859 -- The entity to be generated for the current state declaration
11861 procedure Analyze_External_Option
(Opt
: Node_Id
);
11862 -- Verify the legality of option External
11864 procedure Analyze_External_Property
11866 Expr
: Node_Id
:= Empty
);
11867 -- Verify the legailty of a single external property. Prop
11868 -- denotes the external property. Expr is the expression used
11869 -- to set the property.
11871 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11872 -- Verify the legality of option Part_Of
11874 procedure Check_Duplicate_Option
11876 Status
: in out Boolean);
11877 -- Flag Status denotes whether a particular option has been
11878 -- seen while processing a state. This routine verifies that
11879 -- Opt is not a duplicate option and sets the flag Status
11880 -- (SPARK RM 7.1.4(1)).
11882 procedure Check_Duplicate_Property
11884 Status
: in out Boolean);
11885 -- Flag Status denotes whether a particular property has been
11886 -- seen while processing option External. This routine verifies
11887 -- that Prop is not a duplicate property and sets flag Status.
11888 -- Opt is not a duplicate property and sets the flag Status.
11889 -- (SPARK RM 7.1.4(2))
11891 procedure Check_Ghost_Synchronous
;
11892 -- Ensure that the abstract state is not subject to both Ghost
11893 -- and Synchronous simple options. Emit an error if this is the
11896 procedure Create_Abstract_State
11900 Is_Null
: Boolean);
11901 -- Generate an abstract state entity with name Nam and enter it
11902 -- into visibility. Decl is the "declaration" of the state as
11903 -- it appears in pragma Abstract_State. Loc is the location of
11904 -- the related state "declaration". Flag Is_Null should be set
11905 -- when the associated Abstract_State pragma defines a null
11908 -----------------------------
11909 -- Analyze_External_Option --
11910 -----------------------------
11912 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11913 Errors
: constant Nat
:= Serious_Errors_Detected
;
11915 Props
: Node_Id
:= Empty
;
11918 if Nkind
(Opt
) = N_Component_Association
then
11919 Props
:= Expression
(Opt
);
11922 -- External state with properties
11924 if Present
(Props
) then
11926 -- Multiple properties appear as an aggregate
11928 if Nkind
(Props
) = N_Aggregate
then
11930 -- Simple property form
11932 Prop
:= First
(Expressions
(Props
));
11933 while Present
(Prop
) loop
11934 Analyze_External_Property
(Prop
);
11938 -- Property with expression form
11940 Prop
:= First
(Component_Associations
(Props
));
11941 while Present
(Prop
) loop
11942 Analyze_External_Property
11943 (Prop
=> First
(Choices
(Prop
)),
11944 Expr
=> Expression
(Prop
));
11952 Analyze_External_Property
(Props
);
11955 -- An external state defined without any properties defaults
11956 -- all properties to True.
11965 -- Once all external properties have been processed, verify
11966 -- their mutual interaction. Do not perform the check when
11967 -- at least one of the properties is illegal as this will
11968 -- produce a bogus error.
11970 if Errors
= Serious_Errors_Detected
then
11971 Check_External_Properties
11972 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11974 end Analyze_External_Option
;
11976 -------------------------------
11977 -- Analyze_External_Property --
11978 -------------------------------
11980 procedure Analyze_External_Property
11982 Expr
: Node_Id
:= Empty
)
11984 Expr_Val
: Boolean;
11987 -- Check the placement of "others" (if available)
11989 if Nkind
(Prop
) = N_Others_Choice
then
11990 if Others_Seen
then
11992 ("only one OTHERS choice allowed in option External",
11995 Others_Seen
:= True;
11998 elsif Others_Seen
then
12000 ("OTHERS must be the last property in option External",
12003 -- The only remaining legal options are the four predefined
12004 -- external properties.
12006 elsif Nkind
(Prop
) = N_Identifier
12007 and then Chars
(Prop
) in Name_Async_Readers
12008 | Name_Async_Writers
12009 | Name_Effective_Reads
12010 | Name_Effective_Writes
12014 -- Otherwise the construct is not a valid property
12017 SPARK_Msg_N
("invalid external state property", Prop
);
12021 -- Ensure that the expression of the external state property
12022 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12024 if Present
(Expr
) then
12025 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
12027 if Is_OK_Static_Expression
(Expr
) then
12028 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
12031 ("expression of external state property must be "
12036 -- The lack of expression defaults the property to True
12042 -- Named properties
12044 if Nkind
(Prop
) = N_Identifier
then
12045 if Chars
(Prop
) = Name_Async_Readers
then
12046 Check_Duplicate_Property
(Prop
, AR_Seen
);
12047 AR_Val
:= Expr_Val
;
12049 elsif Chars
(Prop
) = Name_Async_Writers
then
12050 Check_Duplicate_Property
(Prop
, AW_Seen
);
12051 AW_Val
:= Expr_Val
;
12053 elsif Chars
(Prop
) = Name_Effective_Reads
then
12054 Check_Duplicate_Property
(Prop
, ER_Seen
);
12055 ER_Val
:= Expr_Val
;
12058 Check_Duplicate_Property
(Prop
, EW_Seen
);
12059 EW_Val
:= Expr_Val
;
12062 -- The handling of property "others" must take into account
12063 -- all other named properties that have been encountered so
12064 -- far. Only those that have not been seen are affected by
12068 if not AR_Seen
then
12069 AR_Val
:= Expr_Val
;
12072 if not AW_Seen
then
12073 AW_Val
:= Expr_Val
;
12076 if not ER_Seen
then
12077 ER_Val
:= Expr_Val
;
12080 if not EW_Seen
then
12081 EW_Val
:= Expr_Val
;
12084 end Analyze_External_Property
;
12086 ----------------------------
12087 -- Analyze_Part_Of_Option --
12088 ----------------------------
12090 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
12091 Encap
: constant Node_Id
:= Expression
(Opt
);
12092 Constits
: Elist_Id
;
12093 Encap_Id
: Entity_Id
;
12097 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
12100 (Indic
=> First
(Choices
(Opt
)),
12101 Item_Id
=> State_Id
,
12103 Encap_Id
=> Encap_Id
,
12106 -- The Part_Of indicator transforms the abstract state into
12107 -- a constituent of the encapsulating state or single
12108 -- concurrent type.
12111 pragma Assert
(Present
(Encap_Id
));
12112 Constits
:= Part_Of_Constituents
(Encap_Id
);
12114 if No
(Constits
) then
12115 Constits
:= New_Elmt_List
;
12116 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12119 Append_Elmt
(State_Id
, Constits
);
12120 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12122 end Analyze_Part_Of_Option
;
12124 ----------------------------
12125 -- Check_Duplicate_Option --
12126 ----------------------------
12128 procedure Check_Duplicate_Option
12130 Status
: in out Boolean)
12134 SPARK_Msg_N
("duplicate state option", Opt
);
12138 end Check_Duplicate_Option
;
12140 ------------------------------
12141 -- Check_Duplicate_Property --
12142 ------------------------------
12144 procedure Check_Duplicate_Property
12146 Status
: in out Boolean)
12150 SPARK_Msg_N
("duplicate external property", Prop
);
12154 end Check_Duplicate_Property
;
12156 -----------------------------
12157 -- Check_Ghost_Synchronous --
12158 -----------------------------
12160 procedure Check_Ghost_Synchronous
is
12162 -- A synchronized abstract state cannot be Ghost and vice
12163 -- versa (SPARK RM 6.9(19)).
12165 if Ghost_Seen
and Synchronous_Seen
then
12166 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12168 end Check_Ghost_Synchronous
;
12170 ---------------------------
12171 -- Create_Abstract_State --
12172 ---------------------------
12174 procedure Create_Abstract_State
12181 -- The abstract state may be semi-declared when the related
12182 -- package was withed through a limited with clause. In that
12183 -- case reuse the entity to fully declare the state.
12185 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12186 State_Id
:= Entity
(Decl
);
12188 -- Otherwise the elaboration of pragma Abstract_State
12189 -- declares the state.
12192 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12194 if Present
(Decl
) then
12195 Set_Entity
(Decl
, State_Id
);
12199 -- Null states never come from source
12201 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12202 Set_Parent
(State_Id
, State
);
12203 Mutate_Ekind
(State_Id
, E_Abstract_State
);
12204 Set_Etype
(State_Id
, Standard_Void_Type
);
12205 Set_Encapsulating_State
(State_Id
, Empty
);
12207 -- Set the SPARK mode from the current context
12209 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12210 Set_SPARK_Pragma_Inherited
(State_Id
);
12212 -- An abstract state declared within a Ghost region becomes
12213 -- Ghost (SPARK RM 6.9(2)).
12215 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12216 Set_Is_Ghost_Entity
(State_Id
);
12219 -- Establish a link between the state declaration and the
12220 -- abstract state entity. Note that a null state remains as
12221 -- N_Null and does not carry any linkages.
12223 if not Is_Null
then
12224 if Present
(Decl
) then
12225 Set_Entity
(Decl
, State_Id
);
12226 Set_Etype
(Decl
, Standard_Void_Type
);
12229 -- Every non-null state must be defined, nameable and
12232 Push_Scope
(Pack_Id
);
12233 Generate_Definition
(State_Id
);
12234 Enter_Name
(State_Id
);
12237 end Create_Abstract_State
;
12244 -- Start of processing for Analyze_Abstract_State
12247 -- A package with a null abstract state is not allowed to
12248 -- declare additional states.
12252 ("package & has null abstract state", State
, Pack_Id
);
12254 -- Null states appear as internally generated entities
12256 elsif Nkind
(State
) = N_Null
then
12257 Create_Abstract_State
12258 (Nam
=> New_Internal_Name
('S'),
12260 Loc
=> Sloc
(State
),
12264 -- Catch a case where a null state appears in a list of
12265 -- non-null states.
12267 if Non_Null_Seen
then
12269 ("package & has non-null abstract state",
12273 -- Simple state declaration
12275 elsif Nkind
(State
) = N_Identifier
then
12276 Create_Abstract_State
12277 (Nam
=> Chars
(State
),
12279 Loc
=> Sloc
(State
),
12281 Non_Null_Seen
:= True;
12283 -- State declaration with various options. This construct
12284 -- appears as an extension aggregate in the tree.
12286 elsif Nkind
(State
) = N_Extension_Aggregate
then
12287 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12288 Create_Abstract_State
12289 (Nam
=> Chars
(Ancestor_Part
(State
)),
12290 Decl
=> Ancestor_Part
(State
),
12291 Loc
=> Sloc
(Ancestor_Part
(State
)),
12293 Non_Null_Seen
:= True;
12296 ("state name must be an identifier",
12297 Ancestor_Part
(State
));
12300 -- Options External, Ghost and Synchronous appear as
12303 Opt
:= First
(Expressions
(State
));
12304 while Present
(Opt
) loop
12305 if Nkind
(Opt
) = N_Identifier
then
12309 if Chars
(Opt
) = Name_External
then
12310 Check_Duplicate_Option
(Opt
, External_Seen
);
12311 Analyze_External_Option
(Opt
);
12315 elsif Chars
(Opt
) = Name_Ghost
then
12316 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12317 Check_Ghost_Synchronous
;
12319 if Present
(State_Id
) then
12320 Set_Is_Ghost_Entity
(State_Id
);
12325 elsif Chars
(Opt
) = Name_Synchronous
then
12326 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12327 Check_Ghost_Synchronous
;
12329 -- Relaxed_Initialization
12331 elsif Chars
(Opt
) = Name_Relaxed_Initialization
then
12332 Check_Duplicate_Option
12333 (Opt
, Relaxed_Initialization_Seen
);
12335 -- Option Part_Of without an encapsulating state is
12336 -- illegal (SPARK RM 7.1.4(8)).
12338 elsif Chars
(Opt
) = Name_Part_Of
then
12340 ("indicator Part_Of must denote abstract state, "
12341 & "single protected type or single task type",
12344 -- Do not emit an error message when a previous state
12345 -- declaration with options was not parenthesized as
12346 -- the option is actually another state declaration.
12348 -- with Abstract_State
12349 -- (State_1 with ..., -- missing parentheses
12350 -- (State_2 with ...),
12351 -- State_3) -- ok state declaration
12353 elsif Missing_Parentheses
then
12356 -- Otherwise the option is not allowed. Note that it
12357 -- is not possible to distinguish between an option
12358 -- and a state declaration when a previous state with
12359 -- options not properly parentheses.
12361 -- with Abstract_State
12362 -- (State_1 with ..., -- missing parentheses
12363 -- State_2); -- could be an option
12367 ("simple option not allowed in state declaration",
12371 -- Catch a case where missing parentheses around a state
12372 -- declaration with options cause a subsequent state
12373 -- declaration with options to be treated as an option.
12375 -- with Abstract_State
12376 -- (State_1 with ..., -- missing parentheses
12377 -- (State_2 with ...))
12379 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12380 Missing_Parentheses
:= True;
12382 ("state declaration must be parenthesized",
12383 Ancestor_Part
(State
));
12385 -- Otherwise the option is malformed
12388 SPARK_Msg_N
("malformed option", Opt
);
12394 -- Options External and Part_Of appear as component
12397 Opt
:= First
(Component_Associations
(State
));
12398 while Present
(Opt
) loop
12399 Opt_Nam
:= First
(Choices
(Opt
));
12401 if Nkind
(Opt_Nam
) = N_Identifier
then
12402 if Chars
(Opt_Nam
) = Name_External
then
12403 Analyze_External_Option
(Opt
);
12405 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12406 Analyze_Part_Of_Option
(Opt
);
12409 SPARK_Msg_N
("invalid state option", Opt
);
12412 SPARK_Msg_N
("invalid state option", Opt
);
12418 -- Any other attempt to declare a state is illegal
12421 Malformed_State_Error
(State
);
12425 -- Guard against a junk state. In such cases no entity is
12426 -- generated and the subsequent checks cannot be applied.
12428 if Present
(State_Id
) then
12430 -- Verify whether the state does not introduce an illegal
12431 -- hidden state within a package subject to a null abstract
12434 Check_No_Hidden_State
(State_Id
);
12436 -- Check whether the lack of option Part_Of agrees with the
12437 -- placement of the abstract state with respect to the state
12440 if not Part_Of_Seen
then
12441 Check_Missing_Part_Of
(State_Id
);
12444 -- Associate the state with its related package
12446 if No
(Abstract_States
(Pack_Id
)) then
12447 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12450 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12452 end Analyze_Abstract_State
;
12454 ---------------------------
12455 -- Malformed_State_Error --
12456 ---------------------------
12458 procedure Malformed_State_Error
(State
: Node_Id
) is
12460 Error_Msg_N
("malformed abstract state declaration", State
);
12462 -- An abstract state with a simple option is being declared
12463 -- with "=>" rather than the legal "with". The state appears
12464 -- as a component association.
12466 if Nkind
(State
) = N_Component_Association
then
12467 Error_Msg_N
("\use WITH to specify simple option", State
);
12469 end Malformed_State_Error
;
12473 Pack_Decl
: Node_Id
;
12474 Pack_Id
: Entity_Id
;
12478 -- Start of processing for Abstract_State
12482 Check_No_Identifiers
;
12483 Check_Arg_Count
(1);
12485 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12487 if Nkind
(Pack_Decl
) not in
12488 N_Generic_Package_Declaration | N_Package_Declaration
12493 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12495 -- A pragma that applies to a Ghost entity becomes Ghost for the
12496 -- purposes of legality checks and removal of ignored Ghost code.
12498 Mark_Ghost_Pragma
(N
, Pack_Id
);
12499 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12501 -- Chain the pragma on the contract for completeness
12503 Add_Contract_Item
(N
, Pack_Id
);
12505 -- The legality checks of pragmas Abstract_State, Initializes, and
12506 -- Initial_Condition are affected by the SPARK mode in effect. In
12507 -- addition, these three pragmas are subject to an inherent order:
12509 -- 1) Abstract_State
12511 -- 3) Initial_Condition
12513 -- Analyze all these pragmas in the order outlined above
12515 Analyze_If_Present
(Pragma_SPARK_Mode
);
12516 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12518 -- Multiple non-null abstract states appear as an aggregate
12520 if Nkind
(States
) = N_Aggregate
then
12521 State
:= First
(Expressions
(States
));
12522 while Present
(State
) loop
12523 Analyze_Abstract_State
(State
, Pack_Id
);
12527 -- An abstract state with a simple option is being illegaly
12528 -- declared with "=>" rather than "with". In this case the
12529 -- state declaration appears as a component association.
12531 if Present
(Component_Associations
(States
)) then
12532 State
:= First
(Component_Associations
(States
));
12533 while Present
(State
) loop
12534 Malformed_State_Error
(State
);
12539 -- Various forms of a single abstract state. Note that these may
12540 -- include malformed state declarations.
12543 Analyze_Abstract_State
(States
, Pack_Id
);
12546 Analyze_If_Present
(Pragma_Initializes
);
12547 Analyze_If_Present
(Pragma_Initial_Condition
);
12548 end Abstract_State
;
12556 -- Note: this pragma also has some specific processing in Par.Prag
12557 -- because we want to set the Ada version mode during parsing.
12559 when Pragma_Ada_83
=>
12561 Check_Arg_Count
(0);
12563 -- We really should check unconditionally for proper configuration
12564 -- pragma placement, since we really don't want mixed Ada modes
12565 -- within a single unit, and the GNAT reference manual has always
12566 -- said this was a configuration pragma, but we did not check and
12567 -- are hesitant to add the check now.
12569 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12570 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12571 -- or Ada 2012 mode.
12573 if Ada_Version
>= Ada_2005
then
12574 Check_Valid_Configuration_Pragma
;
12577 -- Now set Ada 83 mode
12579 if Latest_Ada_Only
then
12580 Error_Pragma
("??pragma% ignored");
12582 Ada_Version
:= Ada_83
;
12583 Ada_Version_Explicit
:= Ada_83
;
12584 Ada_Version_Pragma
:= N
;
12593 -- Note: this pragma also has some specific processing in Par.Prag
12594 -- because we want to set the Ada 83 version mode during parsing.
12596 when Pragma_Ada_95
=>
12598 Check_Arg_Count
(0);
12600 -- We really should check unconditionally for proper configuration
12601 -- pragma placement, since we really don't want mixed Ada modes
12602 -- within a single unit, and the GNAT reference manual has always
12603 -- said this was a configuration pragma, but we did not check and
12604 -- are hesitant to add the check now.
12606 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12607 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12609 if Ada_Version
>= Ada_2005
then
12610 Check_Valid_Configuration_Pragma
;
12613 -- Now set Ada 95 mode
12615 if Latest_Ada_Only
then
12616 Error_Pragma
("??pragma% ignored");
12618 Ada_Version
:= Ada_95
;
12619 Ada_Version_Explicit
:= Ada_95
;
12620 Ada_Version_Pragma
:= N
;
12623 ---------------------
12624 -- Ada_05/Ada_2005 --
12625 ---------------------
12628 -- pragma Ada_05 (LOCAL_NAME);
12630 -- pragma Ada_2005;
12631 -- pragma Ada_2005 (LOCAL_NAME):
12633 -- Note: these pragmas also have some specific processing in Par.Prag
12634 -- because we want to set the Ada 2005 version mode during parsing.
12636 -- The one argument form is used for managing the transition from
12637 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12638 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12639 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12640 -- mode, a preference rule is established which does not choose
12641 -- such an entity unless it is unambiguously specified. This avoids
12642 -- extra subprograms marked this way from generating ambiguities in
12643 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12644 -- intended for exclusive use in the GNAT run-time library.
12655 if Arg_Count
= 1 then
12656 Check_Arg_Is_Local_Name
(Arg1
);
12657 E_Id
:= Get_Pragma_Arg
(Arg1
);
12659 if Etype
(E_Id
) = Any_Type
then
12663 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12664 Record_Rep_Item
(Entity
(E_Id
), N
);
12667 Check_Arg_Count
(0);
12669 -- For Ada_2005 we unconditionally enforce the documented
12670 -- configuration pragma placement, since we do not want to
12671 -- tolerate mixed modes in a unit involving Ada 2005. That
12672 -- would cause real difficulties for those cases where there
12673 -- are incompatibilities between Ada 95 and Ada 2005.
12675 Check_Valid_Configuration_Pragma
;
12677 -- Now set appropriate Ada mode
12679 if Latest_Ada_Only
then
12680 Error_Pragma
("??pragma% ignored");
12682 Ada_Version
:= Ada_2005
;
12683 Ada_Version_Explicit
:= Ada_2005
;
12684 Ada_Version_Pragma
:= N
;
12689 ---------------------
12690 -- Ada_12/Ada_2012 --
12691 ---------------------
12694 -- pragma Ada_12 (LOCAL_NAME);
12696 -- pragma Ada_2012;
12697 -- pragma Ada_2012 (LOCAL_NAME):
12699 -- Note: these pragmas also have some specific processing in Par.Prag
12700 -- because we want to set the Ada 2012 version mode during parsing.
12702 -- The one argument form is used for managing the transition from Ada
12703 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12704 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12705 -- mode will generate a warning. In addition, in any pre-Ada_2012
12706 -- mode, a preference rule is established which does not choose
12707 -- such an entity unless it is unambiguously specified. This avoids
12708 -- extra subprograms marked this way from generating ambiguities in
12709 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12710 -- intended for exclusive use in the GNAT run-time library.
12721 if Arg_Count
= 1 then
12722 Check_Arg_Is_Local_Name
(Arg1
);
12723 E_Id
:= Get_Pragma_Arg
(Arg1
);
12725 if Etype
(E_Id
) = Any_Type
then
12729 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12730 Record_Rep_Item
(Entity
(E_Id
), N
);
12733 Check_Arg_Count
(0);
12735 -- For Ada_2012 we unconditionally enforce the documented
12736 -- configuration pragma placement, since we do not want to
12737 -- tolerate mixed modes in a unit involving Ada 2012. That
12738 -- would cause real difficulties for those cases where there
12739 -- are incompatibilities between Ada 95 and Ada 2012. We could
12740 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12742 Check_Valid_Configuration_Pragma
;
12744 -- Now set appropriate Ada mode
12746 Ada_Version
:= Ada_2012
;
12747 Ada_Version_Explicit
:= Ada_2012
;
12748 Ada_Version_Pragma
:= N
;
12756 -- pragma Ada_2022;
12757 -- pragma Ada_2022 (LOCAL_NAME):
12759 -- Note: this pragma also has some specific processing in Par.Prag
12760 -- because we want to set the Ada 2022 version mode during parsing.
12762 -- The one argument form is used for managing the transition from Ada
12763 -- 2012 to Ada 2022 in the run-time library. If an entity is marked
12764 -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
12765 -- mode will generate a warning;for calls to Ada_2022 only primitives
12766 -- that require overriding an error will be reported. In addition, in
12767 -- any pre-Ada_2022 mode, a preference rule is established which does
12768 -- not choose such an entity unless it is unambiguously specified.
12769 -- This avoids extra subprograms marked this way from generating
12770 -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
12771 -- argument form is intended for exclusive use in the GNAT run-time
12774 when Pragma_Ada_2022
=>
12781 if Arg_Count
= 1 then
12782 Check_Arg_Is_Local_Name
(Arg1
);
12783 E_Id
:= Get_Pragma_Arg
(Arg1
);
12785 if Etype
(E_Id
) = Any_Type
then
12789 Set_Is_Ada_2022_Only
(Entity
(E_Id
));
12790 Record_Rep_Item
(Entity
(E_Id
), N
);
12793 Check_Arg_Count
(0);
12795 -- For Ada_2022 we unconditionally enforce the documented
12796 -- configuration pragma placement, since we do not want to
12797 -- tolerate mixed modes in a unit involving Ada 2022. That
12798 -- would cause real difficulties for those cases where there
12799 -- are incompatibilities between Ada 2012 and Ada 2022. We
12800 -- could allow mixing of Ada 2012 and Ada 2022 but it's not
12803 Check_Valid_Configuration_Pragma
;
12805 -- Now set appropriate Ada mode
12807 Ada_Version
:= Ada_2022
;
12808 Ada_Version_Explicit
:= Ada_2022
;
12809 Ada_Version_Pragma
:= N
;
12813 -------------------------------------
12814 -- Aggregate_Individually_Assign --
12815 -------------------------------------
12817 -- pragma Aggregate_Individually_Assign;
12819 when Pragma_Aggregate_Individually_Assign
=>
12821 Check_Arg_Count
(0);
12822 Check_Valid_Configuration_Pragma
;
12823 Aggregate_Individually_Assign
:= True;
12825 ----------------------
12826 -- All_Calls_Remote --
12827 ----------------------
12829 -- pragma All_Calls_Remote [(library_package_NAME)];
12831 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12832 Lib_Entity
: Entity_Id
;
12835 Check_Ada_83_Warning
;
12836 Check_Valid_Library_Unit_Pragma
;
12838 -- If N was rewritten as a null statement there is nothing more
12841 if Nkind
(N
) = N_Null_Statement
then
12845 Lib_Entity
:= Find_Lib_Unit_Name
;
12847 -- A pragma that applies to a Ghost entity becomes Ghost for the
12848 -- purposes of legality checks and removal of ignored Ghost code.
12850 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12852 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12854 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12855 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12856 Error_Pragma
("pragma% only apply to rci unit");
12858 -- Set flag for entity of the library unit
12861 Set_Has_All_Calls_Remote
(Lib_Entity
);
12864 end All_Calls_Remote
;
12866 ---------------------------
12867 -- Allow_Integer_Address --
12868 ---------------------------
12870 -- pragma Allow_Integer_Address;
12872 when Pragma_Allow_Integer_Address
=>
12874 Check_Valid_Configuration_Pragma
;
12875 Check_Arg_Count
(0);
12877 -- If Address is a private type, then set the flag to allow
12878 -- integer address values. If Address is not private, then this
12879 -- pragma has no purpose, so it is simply ignored. Not clear if
12880 -- there are any such targets now.
12882 if Opt
.Address_Is_Private
then
12883 Opt
.Allow_Integer_Address
:= True;
12891 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12892 -- ARG ::= NAME | EXPRESSION
12894 -- The first two arguments are by convention intended to refer to an
12895 -- external tool and a tool-specific function. These arguments are
12898 when Pragma_Annotate | Pragma_GNAT_Annotate
=> Annotate
: declare
12903 --------------------------
12904 -- Inferred_String_Type --
12905 --------------------------
12907 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
;
12908 -- Infer the type to use for a string literal or a concatentation
12909 -- of operands whose types can be inferred. For such expressions,
12910 -- returns the "narrowest" of the three predefined string types
12911 -- that can represent the characters occurring in the expression.
12912 -- For other expressions, returns Empty.
12914 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
is
12916 case Nkind
(Expr
) is
12917 when N_String_Literal
=>
12918 if Has_Wide_Wide_Character
(Expr
) then
12919 return Standard_Wide_Wide_String
;
12920 elsif Has_Wide_Character
(Expr
) then
12921 return Standard_Wide_String
;
12923 return Standard_String
;
12926 when N_Op_Concat
=>
12928 L_Type
: constant Entity_Id
12929 := Preferred_String_Type
(Left_Opnd
(Expr
));
12930 R_Type
: constant Entity_Id
12931 := Preferred_String_Type
(Right_Opnd
(Expr
));
12933 Type_Table
: constant array (1 .. 4) of Entity_Id
12935 Standard_Wide_Wide_String
,
12936 Standard_Wide_String
,
12939 for Idx
in Type_Table
'Range loop
12940 if (L_Type
= Type_Table
(Idx
)) or
12941 (R_Type
= Type_Table
(Idx
))
12943 return Type_Table
(Idx
);
12946 raise Program_Error
;
12952 end Preferred_String_Type
;
12955 Check_At_Least_N_Arguments
(1);
12957 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12959 -- Determine whether the last argument is "Entity => local_NAME"
12960 -- and if it is, perform the required semantic checks. Remove the
12961 -- argument from further processing.
12963 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12964 and then Chars
(Nam_Arg
) = Name_Entity
12966 Check_Arg_Is_Local_Name
(Nam_Arg
);
12967 Arg_Count
:= Arg_Count
- 1;
12969 -- A pragma that applies to a Ghost entity becomes Ghost for
12970 -- the purposes of legality checks and removal of ignored Ghost
12973 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12974 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12976 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12980 -- Continue the processing with last argument removed for now
12982 Check_Arg_Is_Identifier
(Arg1
);
12983 Check_No_Identifiers
;
12986 -- The second parameter is optional, it is never analyzed
12991 -- Otherwise there is a second parameter
12994 -- The second parameter must be an identifier
12996 Check_Arg_Is_Identifier
(Arg2
);
12998 -- Process the remaining parameters (if any)
13000 Arg
:= Next
(Arg2
);
13001 while Present
(Arg
) loop
13002 Expr
:= Get_Pragma_Arg
(Arg
);
13005 if Is_Entity_Name
(Expr
) then
13008 -- For string literals and concatenations of string literals
13009 -- we assume Standard_String as the type, unless the string
13010 -- contains wide or wide_wide characters.
13012 elsif Present
(Preferred_String_Type
(Expr
)) then
13013 Resolve
(Expr
, Preferred_String_Type
(Expr
));
13015 elsif Is_Overloaded
(Expr
) then
13016 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13027 -------------------------------------------------
13028 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13029 -------------------------------------------------
13032 -- ( [Check => ] Boolean_EXPRESSION
13033 -- [, [Message =>] Static_String_EXPRESSION]);
13035 -- pragma Assert_And_Cut
13036 -- ( [Check => ] Boolean_EXPRESSION
13037 -- [, [Message =>] Static_String_EXPRESSION]);
13040 -- ( [Check => ] Boolean_EXPRESSION
13041 -- [, [Message =>] Static_String_EXPRESSION]);
13043 -- pragma Loop_Invariant
13044 -- ( [Check => ] Boolean_EXPRESSION
13045 -- [, [Message =>] Static_String_EXPRESSION]);
13048 | Pragma_Assert_And_Cut
13050 | Pragma_Loop_Invariant
13053 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13054 -- Determine whether expression Expr contains a Loop_Entry
13055 -- attribute reference.
13057 -------------------------
13058 -- Contains_Loop_Entry --
13059 -------------------------
13061 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13062 Has_Loop_Entry
: Boolean := False;
13064 function Process
(N
: Node_Id
) return Traverse_Result
;
13065 -- Process function for traversal to look for Loop_Entry
13071 function Process
(N
: Node_Id
) return Traverse_Result
is
13073 if Nkind
(N
) = N_Attribute_Reference
13074 and then Attribute_Name
(N
) = Name_Loop_Entry
13076 Has_Loop_Entry
:= True;
13083 procedure Traverse
is new Traverse_Proc
(Process
);
13085 -- Start of processing for Contains_Loop_Entry
13089 return Has_Loop_Entry
;
13090 end Contains_Loop_Entry
;
13095 New_Args
: List_Id
;
13097 -- Start of processing for Assert
13100 -- Assert is an Ada 2005 RM-defined pragma
13102 if Prag_Id
= Pragma_Assert
then
13105 -- The remaining ones are GNAT pragmas
13111 Check_At_Least_N_Arguments
(1);
13112 Check_At_Most_N_Arguments
(2);
13113 Check_Arg_Order
((Name_Check
, Name_Message
));
13114 Check_Optional_Identifier
(Arg1
, Name_Check
);
13115 Expr
:= Get_Pragma_Arg
(Arg1
);
13117 -- Special processing for Loop_Invariant, Loop_Variant or for
13118 -- other cases where a Loop_Entry attribute is present. If the
13119 -- assertion pragma contains attribute Loop_Entry, ensure that
13120 -- the related pragma is within a loop.
13122 if Prag_Id
= Pragma_Loop_Invariant
13123 or else Prag_Id
= Pragma_Loop_Variant
13124 or else Contains_Loop_Entry
(Expr
)
13126 Check_Loop_Pragma_Placement
;
13128 -- Perform preanalysis to deal with embedded Loop_Entry
13131 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13134 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13135 -- a corresponding Check pragma:
13137 -- pragma Check (name, condition [, msg]);
13139 -- Where name is the identifier matching the pragma name. So
13140 -- rewrite pragma in this manner, transfer the message argument
13141 -- if present, and analyze the result
13143 -- Note: When dealing with a semantically analyzed tree, the
13144 -- information that a Check node N corresponds to a source Assert,
13145 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13146 -- pragma kind of Original_Node(N).
13148 New_Args
:= New_List
(
13149 Make_Pragma_Argument_Association
(Loc
,
13150 Expression
=> Make_Identifier
(Loc
, Pname
)),
13151 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13152 Expression
=> Expr
));
13154 if Arg_Count
> 1 then
13155 Check_Optional_Identifier
(Arg2
, Name_Message
);
13157 -- Provide semantic annotations for optional argument, for
13158 -- ASIS use, before rewriting.
13159 -- Is this still needed???
13161 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13162 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13165 -- Rewrite as Check pragma
13169 Chars
=> Name_Check
,
13170 Pragma_Argument_Associations
=> New_Args
));
13175 ----------------------
13176 -- Assertion_Policy --
13177 ----------------------
13179 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13181 -- The following form is Ada 2012 only, but we allow it in all modes
13183 -- Pragma Assertion_Policy (
13184 -- ASSERTION_KIND => POLICY_IDENTIFIER
13185 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13187 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13189 -- RM_ASSERTION_KIND ::= Assert |
13190 -- Static_Predicate |
13191 -- Dynamic_Predicate |
13196 -- Type_Invariant |
13197 -- Type_Invariant'Class |
13198 -- Default_Initial_Condition
13200 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13202 -- Contract_Cases |
13205 -- Initial_Condition |
13206 -- Loop_Invariant |
13212 -- Statement_Assertions |
13213 -- Subprogram_Variant
13215 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13216 -- ID_ASSERTION_KIND list contains implementation-defined additions
13217 -- recognized by GNAT. The effect is to control the behavior of
13218 -- identically named aspects and pragmas, depending on the specified
13219 -- policy identifier:
13221 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13223 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13224 -- implementation-defined addition that results in totally ignoring
13225 -- the corresponding assertion. If Disable is specified, then the
13226 -- argument of the assertion is not even analyzed. This is useful
13227 -- when the aspect/pragma argument references entities in a with'ed
13228 -- package that is replaced by a dummy package in the final build.
13230 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13231 -- and Type_Invariant'Class were recognized by the parser and
13232 -- transformed into references to the special internal identifiers
13233 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13234 -- processing is required here.
13236 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13237 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13238 -- Converts the assertion policy 'Suppressible' to either Check or
13239 -- Ignore based on whether checks are suppressed via -gnatp.
13241 --------------------------
13242 -- Resolve_Suppressible --
13243 --------------------------
13245 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13246 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13250 -- Transform policy argument Suppressible into either Ignore or
13251 -- Check depending on whether checks are enabled or suppressed.
13253 if Chars
(Arg
) = Name_Suppressible
then
13254 if Suppress_Checks
then
13255 Nam
:= Name_Ignore
;
13260 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13262 end Resolve_Suppressible
;
13274 -- This can always appear as a configuration pragma
13276 if Is_Configuration_Pragma
then
13279 -- It can also appear in a declarative part or package spec in Ada
13280 -- 2012 mode. We allow this in other modes, but in that case we
13281 -- consider that we have an Ada 2012 pragma on our hands.
13284 Check_Is_In_Decl_Part_Or_Package_Spec
;
13288 -- One argument case with no identifier (first form above)
13291 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13292 or else Chars
(Arg1
) = No_Name
)
13294 Check_Arg_Is_One_Of
(Arg1
,
13295 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13297 Resolve_Suppressible
(Arg1
);
13299 -- Treat one argument Assertion_Policy as equivalent to:
13301 -- pragma Check_Policy (Assertion, policy)
13303 -- So rewrite pragma in that manner and link on to the chain
13304 -- of Check_Policy pragmas, marking the pragma as analyzed.
13306 Policy
:= Get_Pragma_Arg
(Arg1
);
13310 Chars
=> Name_Check_Policy
,
13311 Pragma_Argument_Associations
=> New_List
(
13312 Make_Pragma_Argument_Association
(Loc
,
13313 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13315 Make_Pragma_Argument_Association
(Loc
,
13317 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13320 -- Here if we have two or more arguments
13323 Check_At_Least_N_Arguments
(1);
13326 -- Loop through arguments
13329 while Present
(Arg
) loop
13330 LocP
:= Sloc
(Arg
);
13332 -- Kind must be specified
13334 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13335 or else Chars
(Arg
) = No_Name
13338 ("missing assertion kind for pragma%", Arg
);
13341 -- Check Kind and Policy have allowed forms
13343 Kind
:= Chars
(Arg
);
13344 Policy
:= Get_Pragma_Arg
(Arg
);
13346 if not Is_Valid_Assertion_Kind
(Kind
) then
13348 ("invalid assertion kind for pragma%", Arg
);
13351 Check_Arg_Is_One_Of
(Arg
,
13352 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13354 Resolve_Suppressible
(Arg
);
13356 if Kind
= Name_Ghost
then
13358 -- The Ghost policy must be either Check or Ignore
13359 -- (SPARK RM 6.9(6)).
13361 if Chars
(Policy
) not in Name_Check | Name_Ignore
then
13363 ("argument of pragma % Ghost must be Check or "
13364 & "Ignore", Policy
);
13367 -- Pragma Assertion_Policy specifying a Ghost policy
13368 -- cannot occur within a Ghost subprogram or package
13369 -- (SPARK RM 6.9(14)).
13371 if Ghost_Mode
> None
then
13373 ("pragma % cannot appear within ghost subprogram or "
13378 -- Rewrite the Assertion_Policy pragma as a series of
13379 -- Check_Policy pragmas of the form:
13381 -- Check_Policy (Kind, Policy);
13383 -- Note: the insertion of the pragmas cannot be done with
13384 -- Insert_Action because in the configuration case, there
13385 -- are no scopes on the scope stack and the mechanism will
13388 Insert_Before_And_Analyze
(N
,
13390 Chars
=> Name_Check_Policy
,
13391 Pragma_Argument_Associations
=> New_List
(
13392 Make_Pragma_Argument_Association
(LocP
,
13393 Expression
=> Make_Identifier
(LocP
, Kind
)),
13394 Make_Pragma_Argument_Association
(LocP
,
13395 Expression
=> Policy
))));
13400 -- Rewrite the Assertion_Policy pragma as null since we have
13401 -- now inserted all the equivalent Check pragmas.
13403 Rewrite
(N
, Make_Null_Statement
(Loc
));
13406 end Assertion_Policy
;
13408 ------------------------------
13409 -- Assume_No_Invalid_Values --
13410 ------------------------------
13412 -- pragma Assume_No_Invalid_Values (On | Off);
13414 when Pragma_Assume_No_Invalid_Values
=>
13416 Check_Valid_Configuration_Pragma
;
13417 Check_Arg_Count
(1);
13418 Check_No_Identifiers
;
13419 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13421 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13422 Assume_No_Invalid_Values
:= True;
13424 Assume_No_Invalid_Values
:= False;
13427 --------------------------
13428 -- Attribute_Definition --
13429 --------------------------
13431 -- pragma Attribute_Definition
13432 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13433 -- [Entity =>] LOCAL_NAME,
13434 -- [Expression =>] EXPRESSION | NAME);
13436 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13437 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13442 Check_Arg_Count
(3);
13443 Check_Optional_Identifier
(Arg1
, "attribute");
13444 Check_Optional_Identifier
(Arg2
, "entity");
13445 Check_Optional_Identifier
(Arg3
, "expression");
13447 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13448 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13452 Check_Arg_Is_Local_Name
(Arg2
);
13454 -- If the attribute is not recognized, then issue a warning (not
13455 -- an error), and ignore the pragma.
13457 Aname
:= Chars
(Attribute_Designator
);
13459 if not Is_Attribute_Name
(Aname
) then
13460 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13464 -- Otherwise, rewrite the pragma as an attribute definition clause
13467 Make_Attribute_Definition_Clause
(Loc
,
13468 Name
=> Get_Pragma_Arg
(Arg2
),
13470 Expression
=> Get_Pragma_Arg
(Arg3
)));
13472 end Attribute_Definition
;
13474 ------------------------------------------------------------------
13475 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13477 ------------------------------------------------------------------
13479 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13480 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13481 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13482 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13483 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13485 when Pragma_Async_Readers
13486 | Pragma_Async_Writers
13487 | Pragma_Effective_Reads
13488 | Pragma_Effective_Writes
13489 | Pragma_No_Caching
13491 Async_Effective
: declare
13492 Obj_Or_Type_Decl
: Node_Id
;
13493 Obj_Or_Type_Id
: Entity_Id
;
13496 Check_No_Identifiers
;
13497 Check_At_Most_N_Arguments
(1);
13499 Obj_Or_Type_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13501 -- Pragma must apply to a object declaration or to a type
13502 -- declaration. Original_Node is necessary to account for
13503 -- untagged derived types that are rewritten as subtypes of
13504 -- their respective root types.
13506 if Nkind
(Obj_Or_Type_Decl
) /= N_Object_Declaration
13507 and then Nkind
(Original_Node
(Obj_Or_Type_Decl
)) not in
13508 N_Full_Type_Declaration |
13509 N_Private_Type_Declaration |
13510 N_Formal_Type_Declaration |
13511 N_Task_Type_Declaration |
13512 N_Protected_Type_Declaration
13517 Obj_Or_Type_Id
:= Defining_Entity
(Obj_Or_Type_Decl
);
13519 -- Perform minimal verification to ensure that the argument is at
13520 -- least an object or a type. Subsequent finer grained checks will
13521 -- be done at the end of the declarative region that contains the
13524 if Ekind
(Obj_Or_Type_Id
) in E_Constant | E_Variable
13525 or else Is_Type
(Obj_Or_Type_Id
)
13528 -- In the case of a type, pragma is a type-related
13529 -- representation item and so requires checks common to
13530 -- all type-related representation items.
13532 if Is_Type
(Obj_Or_Type_Id
)
13533 and then Rep_Item_Too_Late
(Obj_Or_Type_Id
, N
)
13538 -- A pragma that applies to a Ghost entity becomes Ghost for
13539 -- the purposes of legality checks and removal of ignored Ghost
13542 Mark_Ghost_Pragma
(N
, Obj_Or_Type_Id
);
13544 -- Chain the pragma on the contract for further processing by
13545 -- Analyze_External_Property_In_Decl_Part.
13547 Add_Contract_Item
(N
, Obj_Or_Type_Id
);
13549 -- Analyze the Boolean expression (if any)
13551 if Present
(Arg1
) then
13552 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13555 -- Otherwise the external property applies to a constant
13559 ("pragma % must apply to a volatile type or object");
13561 end Async_Effective
;
13567 -- pragma Asynchronous (LOCAL_NAME);
13569 when Pragma_Asynchronous
=> Asynchronous
: declare
13572 Formal
: Entity_Id
;
13577 procedure Process_Async_Pragma
;
13578 -- Common processing for procedure and access-to-procedure case
13580 --------------------------
13581 -- Process_Async_Pragma --
13582 --------------------------
13584 procedure Process_Async_Pragma
is
13587 Set_Is_Asynchronous
(Nm
);
13591 -- The formals should be of mode IN (RM E.4.1(6))
13594 while Present
(S
) loop
13595 Formal
:= Defining_Identifier
(S
);
13597 if Nkind
(Formal
) = N_Defining_Identifier
13598 and then Ekind
(Formal
) /= E_In_Parameter
13601 ("pragma% procedure can only have IN parameter",
13608 Set_Is_Asynchronous
(Nm
);
13609 end Process_Async_Pragma
;
13611 -- Start of processing for pragma Asynchronous
13614 Check_Ada_83_Warning
;
13615 Check_No_Identifiers
;
13616 Check_Arg_Count
(1);
13617 Check_Arg_Is_Local_Name
(Arg1
);
13619 if Debug_Flag_U
then
13623 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13624 Analyze
(Get_Pragma_Arg
(Arg1
));
13625 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
13627 -- A pragma that applies to a Ghost entity becomes Ghost for the
13628 -- purposes of legality checks and removal of ignored Ghost code.
13630 Mark_Ghost_Pragma
(N
, Nm
);
13632 if not Is_Remote_Call_Interface
(C_Ent
)
13633 and then not Is_Remote_Types
(C_Ent
)
13635 -- This pragma should only appear in an RCI or Remote Types
13636 -- unit (RM E.4.1(4)).
13639 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13642 if Ekind
(Nm
) = E_Procedure
13643 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13645 if not Is_Remote_Call_Interface
(Nm
) then
13647 ("pragma% cannot be applied on non-remote procedure",
13651 L
:= Parameter_Specifications
(Parent
(Nm
));
13652 Process_Async_Pragma
;
13655 elsif Ekind
(Nm
) = E_Function
then
13657 ("pragma% cannot be applied to function", Arg1
);
13659 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13660 if Is_Record_Type
(Nm
) then
13662 -- A record type that is the Equivalent_Type for a remote
13663 -- access-to-subprogram type.
13665 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13668 -- A non-expanded RAS type (distribution is not enabled)
13670 Decl
:= Declaration_Node
(Nm
);
13673 if Nkind
(Decl
) = N_Full_Type_Declaration
13674 and then Nkind
(Type_Definition
(Decl
)) =
13675 N_Access_Procedure_Definition
13677 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13678 Process_Async_Pragma
;
13680 if Is_Asynchronous
(Nm
)
13681 and then Expander_Active
13682 and then Get_PCS_Name
/= Name_No_DSA
13684 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13689 ("pragma% cannot reference access-to-function type",
13693 -- Only other possibility is access-to-class-wide type
13695 elsif Is_Access_Type
(Nm
)
13696 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13698 Check_First_Subtype
(Arg1
);
13699 Set_Is_Asynchronous
(Nm
);
13700 if Expander_Active
then
13701 RACW_Type_Is_Asynchronous
(Nm
);
13705 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13713 -- pragma Atomic (LOCAL_NAME);
13715 when Pragma_Atomic
=>
13716 Process_Atomic_Independent_Shared_Volatile
;
13718 -----------------------
13719 -- Atomic_Components --
13720 -----------------------
13722 -- pragma Atomic_Components (array_LOCAL_NAME);
13724 -- This processing is shared by Volatile_Components
13726 when Pragma_Atomic_Components
13727 | Pragma_Volatile_Components
13729 Atomic_Components
: declare
13735 Check_Ada_83_Warning
;
13736 Check_No_Identifiers
;
13737 Check_Arg_Count
(1);
13738 Check_Arg_Is_Local_Name
(Arg1
);
13739 E_Id
:= Get_Pragma_Arg
(Arg1
);
13741 if Etype
(E_Id
) = Any_Type
then
13745 E
:= Entity
(E_Id
);
13747 -- A pragma that applies to a Ghost entity becomes Ghost for the
13748 -- purposes of legality checks and removal of ignored Ghost code.
13750 Mark_Ghost_Pragma
(N
, E
);
13751 Check_Duplicate_Pragma
(E
);
13753 if Rep_Item_Too_Early
(E
, N
)
13755 Rep_Item_Too_Late
(E
, N
)
13760 D
:= Declaration_Node
(E
);
13762 if (Nkind
(D
) = N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13764 (Nkind
(D
) = N_Object_Declaration
13765 and then Ekind
(E
) in E_Constant | E_Variable
13766 and then Nkind
(Object_Definition
(D
)) =
13767 N_Constrained_Array_Definition
)
13769 (Ada_Version
>= Ada_2022
13770 and then Nkind
(D
) = N_Formal_Type_Declaration
)
13772 -- The flag is set on the base type, or on the object
13774 if Nkind
(D
) = N_Full_Type_Declaration
then
13775 E
:= Base_Type
(E
);
13778 -- Atomic implies both Independent and Volatile
13780 if Prag_Id
= Pragma_Atomic_Components
then
13781 Set_Has_Atomic_Components
(E
);
13782 Set_Has_Independent_Components
(E
);
13785 Set_Has_Volatile_Components
(E
);
13788 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13790 end Atomic_Components
;
13792 --------------------
13793 -- Attach_Handler --
13794 --------------------
13796 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13798 when Pragma_Attach_Handler
=>
13799 Check_Ada_83_Warning
;
13800 Check_No_Identifiers
;
13801 Check_Arg_Count
(2);
13803 if No_Run_Time_Mode
then
13804 Error_Msg_CRT
("Attach_Handler pragma", N
);
13806 Check_Interrupt_Or_Attach_Handler
;
13808 -- The expression that designates the attribute may depend on a
13809 -- discriminant, and is therefore a per-object expression, to
13810 -- be expanded in the init proc. If expansion is enabled, then
13811 -- perform semantic checks on a copy only.
13816 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13819 -- In Relaxed_RM_Semantics mode, we allow any static
13820 -- integer value, for compatibility with other compilers.
13822 if Relaxed_RM_Semantics
13823 and then Nkind
(Parg2
) = N_Integer_Literal
13825 Typ
:= Standard_Integer
;
13827 Typ
:= RTE
(RE_Interrupt_ID
);
13830 if Expander_Active
then
13831 Temp
:= New_Copy_Tree
(Parg2
);
13832 Set_Parent
(Temp
, N
);
13833 Preanalyze_And_Resolve
(Temp
, Typ
);
13836 Resolve
(Parg2
, Typ
);
13840 Process_Interrupt_Or_Attach_Handler
;
13843 --------------------
13844 -- C_Pass_By_Copy --
13845 --------------------
13847 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13849 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13855 Check_Valid_Configuration_Pragma
;
13856 Check_Arg_Count
(1);
13857 Check_Optional_Identifier
(Arg1
, "max_size");
13859 Arg
:= Get_Pragma_Arg
(Arg1
);
13860 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13862 Val
:= Expr_Value
(Arg
);
13866 ("maximum size for pragma% must be positive", Arg1
);
13868 elsif UI_Is_In_Int_Range
(Val
) then
13869 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13871 -- If a giant value is given, Int'Last will do well enough.
13872 -- If sometime someone complains that a record larger than
13873 -- two gigabytes is not copied, we will worry about it then.
13876 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13878 end C_Pass_By_Copy
;
13884 -- pragma Check ([Name =>] CHECK_KIND,
13885 -- [Check =>] Boolean_EXPRESSION
13886 -- [,[Message =>] String_EXPRESSION]);
13888 -- CHECK_KIND ::= IDENTIFIER |
13891 -- Invariant'Class |
13892 -- Type_Invariant'Class
13894 -- The identifiers Assertions and Statement_Assertions are not
13895 -- allowed, since they have special meaning for Check_Policy.
13897 -- WARNING: The code below manages Ghost regions. Return statements
13898 -- must be replaced by gotos which jump to the end of the code and
13899 -- restore the Ghost mode.
13901 when Pragma_Check
=> Check
: declare
13902 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13903 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13904 -- Save the Ghost-related attributes to restore on exit
13910 pragma Warnings
(Off
, Str
);
13913 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13914 -- the mode now to ensure that any nodes generated during analysis
13915 -- and expansion are marked as Ghost.
13917 Set_Ghost_Mode
(N
);
13920 Check_At_Least_N_Arguments
(2);
13921 Check_At_Most_N_Arguments
(3);
13922 Check_Optional_Identifier
(Arg1
, Name_Name
);
13923 Check_Optional_Identifier
(Arg2
, Name_Check
);
13925 if Arg_Count
= 3 then
13926 Check_Optional_Identifier
(Arg3
, Name_Message
);
13927 Str
:= Get_Pragma_Arg
(Arg3
);
13930 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13931 Check_Arg_Is_Identifier
(Arg1
);
13932 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13934 -- Check forbidden name Assertions or Statement_Assertions
13937 when Name_Assertions
=>
13939 ("""Assertions"" is not allowed as a check kind for "
13940 & "pragma%", Arg1
);
13942 when Name_Statement_Assertions
=>
13944 ("""Statement_Assertions"" is not allowed as a check kind "
13945 & "for pragma%", Arg1
);
13951 -- Check applicable policy. We skip this if Checked/Ignored status
13952 -- is already set (e.g. in the case of a pragma from an aspect).
13954 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13957 -- For a non-source pragma that is a rewriting of another pragma,
13958 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13960 elsif Is_Rewrite_Substitution
(N
)
13961 and then Nkind
(Original_Node
(N
)) = N_Pragma
13963 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13964 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13966 -- Otherwise query the applicable policy at this point
13969 case Check_Kind
(Cname
) is
13970 when Name_Ignore
=>
13971 Set_Is_Ignored
(N
, True);
13972 Set_Is_Checked
(N
, False);
13975 Set_Is_Ignored
(N
, False);
13976 Set_Is_Checked
(N
, True);
13978 -- For disable, rewrite pragma as null statement and skip
13979 -- rest of the analysis of the pragma.
13981 when Name_Disable
=>
13982 Rewrite
(N
, Make_Null_Statement
(Loc
));
13986 -- No other possibilities
13989 raise Program_Error
;
13993 -- If check kind was not Disable, then continue pragma analysis
13995 Expr
:= Get_Pragma_Arg
(Arg2
);
13997 -- Mark the pragma (or, if rewritten from an aspect, the original
13998 -- aspect) as enabled. Nothing to do for an internally generated
13999 -- check for a dynamic predicate.
14002 and then not Split_PPC
(N
)
14003 and then Cname
/= Name_Dynamic_Predicate
14005 Set_SCO_Pragma_Enabled
(Loc
);
14008 -- Deal with analyzing the string argument. If checks are not
14009 -- on we don't want any expansion (since such expansion would
14010 -- not get properly deleted) but we do want to analyze (to get
14011 -- proper references). The Preanalyze_And_Resolve routine does
14012 -- just what we want. Ditto if pragma is active, because it will
14013 -- be rewritten as an if-statement whose analysis will complete
14014 -- analysis and expansion of the string message. This makes a
14015 -- difference in the unusual case where the expression for the
14016 -- string may have a side effect, such as raising an exception.
14017 -- This is mandated by RM 11.4.2, which specifies that the string
14018 -- expression is only evaluated if the check fails and
14019 -- Assertion_Error is to be raised.
14021 if Arg_Count
= 3 then
14022 Preanalyze_And_Resolve
(Str
, Standard_String
);
14025 -- Now you might think we could just do the same with the Boolean
14026 -- expression if checks are off (and expansion is on) and then
14027 -- rewrite the check as a null statement. This would work but we
14028 -- would lose the useful warnings about an assertion being bound
14029 -- to fail even if assertions are turned off.
14031 -- So instead we wrap the boolean expression in an if statement
14032 -- that looks like:
14034 -- if False and then condition then
14038 -- The reason we do this rewriting during semantic analysis rather
14039 -- than as part of normal expansion is that we cannot analyze and
14040 -- expand the code for the boolean expression directly, or it may
14041 -- cause insertion of actions that would escape the attempt to
14042 -- suppress the check code.
14044 -- Note that the Sloc for the if statement corresponds to the
14045 -- argument condition, not the pragma itself. The reason for
14046 -- this is that we may generate a warning if the condition is
14047 -- False at compile time, and we do not want to delete this
14048 -- warning when we delete the if statement.
14050 if Expander_Active
and Is_Ignored
(N
) then
14051 Eloc
:= Sloc
(Expr
);
14054 Make_If_Statement
(Eloc
,
14056 Make_And_Then
(Eloc
,
14057 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14058 Right_Opnd
=> Expr
),
14059 Then_Statements
=> New_List
(
14060 Make_Null_Statement
(Eloc
))));
14062 -- Now go ahead and analyze the if statement
14064 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14066 -- One rather special treatment. If we are now in Eliminated
14067 -- overflow mode, then suppress overflow checking since we do
14068 -- not want to drag in the bignum stuff if we are in Ignore
14069 -- mode anyway. This is particularly important if we are using
14070 -- a configurable run time that does not support bignum ops.
14072 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14074 Svo
: constant Boolean :=
14075 Scope_Suppress
.Suppress
(Overflow_Check
);
14077 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14078 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14080 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14081 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14084 -- Not that special case
14090 -- All done with this check
14092 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14094 -- Check is active or expansion not active. In these cases we can
14095 -- just go ahead and analyze the boolean with no worries.
14098 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14099 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14100 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14103 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14106 --------------------------
14107 -- Check_Float_Overflow --
14108 --------------------------
14110 -- pragma Check_Float_Overflow;
14112 when Pragma_Check_Float_Overflow
=>
14114 Check_Valid_Configuration_Pragma
;
14115 Check_Arg_Count
(0);
14116 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14122 -- pragma Check_Name (check_IDENTIFIER);
14124 when Pragma_Check_Name
=>
14126 Check_No_Identifiers
;
14127 Check_Valid_Configuration_Pragma
;
14128 Check_Arg_Count
(1);
14129 Check_Arg_Is_Identifier
(Arg1
);
14132 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14135 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14136 if Check_Names
.Table
(J
) = Nam
then
14141 Check_Names
.Append
(Nam
);
14148 -- This is the old style syntax, which is still allowed in all modes:
14150 -- pragma Check_Policy ([Name =>] CHECK_KIND
14151 -- [Policy =>] POLICY_IDENTIFIER);
14153 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14155 -- CHECK_KIND ::= IDENTIFIER |
14158 -- Type_Invariant'Class |
14161 -- This is the new style syntax, compatible with Assertion_Policy
14162 -- and also allowed in all modes.
14164 -- Pragma Check_Policy (
14165 -- CHECK_KIND => POLICY_IDENTIFIER
14166 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14168 -- Note: the identifiers Name and Policy are not allowed as
14169 -- Check_Kind values. This avoids ambiguities between the old and
14170 -- new form syntax.
14172 when Pragma_Check_Policy
=> Check_Policy
: declare
14177 Check_At_Least_N_Arguments
(1);
14179 -- A Check_Policy pragma can appear either as a configuration
14180 -- pragma, or in a declarative part or a package spec (see RM
14181 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14182 -- followed for Check_Policy).
14184 if not Is_Configuration_Pragma
then
14185 Check_Is_In_Decl_Part_Or_Package_Spec
;
14188 -- Figure out if we have the old or new syntax. We have the
14189 -- old syntax if the first argument has no identifier, or the
14190 -- identifier is Name.
14192 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14193 or else Chars
(Arg1
) in No_Name | Name_Name
14197 Check_Arg_Count
(2);
14198 Check_Optional_Identifier
(Arg1
, Name_Name
);
14199 Kind
:= Get_Pragma_Arg
(Arg1
);
14200 Rewrite_Assertion_Kind
(Kind
,
14201 From_Policy
=> Comes_From_Source
(N
));
14202 Check_Arg_Is_Identifier
(Arg1
);
14204 -- Check forbidden check kind
14206 if Chars
(Kind
) in Name_Name | Name_Policy
then
14207 Error_Msg_Name_2
:= Chars
(Kind
);
14209 ("pragma% does not allow% as check name", Arg1
);
14214 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14215 Check_Arg_Is_One_Of
14217 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14219 -- And chain pragma on the Check_Policy_List for search
14221 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14222 Opt
.Check_Policy_List
:= N
;
14224 -- For the new syntax, what we do is to convert each argument to
14225 -- an old syntax equivalent. We do that because we want to chain
14226 -- old style Check_Policy pragmas for the search (we don't want
14227 -- to have to deal with multiple arguments in the search).
14238 while Present
(Arg
) loop
14239 LocP
:= Sloc
(Arg
);
14240 Argx
:= Get_Pragma_Arg
(Arg
);
14242 -- Kind must be specified
14244 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14245 or else Chars
(Arg
) = No_Name
14248 ("missing assertion kind for pragma%", Arg
);
14251 -- Construct equivalent old form syntax Check_Policy
14252 -- pragma and insert it to get remaining checks.
14256 Chars
=> Name_Check_Policy
,
14257 Pragma_Argument_Associations
=> New_List
(
14258 Make_Pragma_Argument_Association
(LocP
,
14260 Make_Identifier
(LocP
, Chars
(Arg
))),
14261 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14262 Expression
=> Argx
)));
14266 -- For a configuration pragma, insert old form in
14267 -- the corresponding file.
14269 if Is_Configuration_Pragma
then
14270 Insert_After
(N
, New_P
);
14274 Insert_Action
(N
, New_P
);
14278 -- Rewrite original Check_Policy pragma to null, since we
14279 -- have converted it into a series of old syntax pragmas.
14281 Rewrite
(N
, Make_Null_Statement
(Loc
));
14291 -- pragma Comment (static_string_EXPRESSION)
14293 -- Processing for pragma Comment shares the circuitry for pragma
14294 -- Ident. The only differences are that Ident enforces a limit of 31
14295 -- characters on its argument, and also enforces limitations on
14296 -- placement for DEC compatibility. Pragma Comment shares neither of
14297 -- these restrictions.
14299 -------------------
14300 -- Common_Object --
14301 -------------------
14303 -- pragma Common_Object (
14304 -- [Internal =>] LOCAL_NAME
14305 -- [, [External =>] EXTERNAL_SYMBOL]
14306 -- [, [Size =>] EXTERNAL_SYMBOL]);
14308 -- Processing for this pragma is shared with Psect_Object
14310 ----------------------------------------------
14311 -- Compile_Time_Error, Compile_Time_Warning --
14312 ----------------------------------------------
14314 -- pragma Compile_Time_Error
14315 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14317 -- pragma Compile_Time_Warning
14318 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14320 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning
=>
14323 Process_Compile_Time_Warning_Or_Error
;
14325 -----------------------------
14326 -- Complete_Representation --
14327 -----------------------------
14329 -- pragma Complete_Representation;
14331 when Pragma_Complete_Representation
=>
14333 Check_Arg_Count
(0);
14335 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14337 ("pragma & must appear within record representation clause");
14340 ----------------------------
14341 -- Complex_Representation --
14342 ----------------------------
14344 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14346 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14353 Check_Arg_Count
(1);
14354 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14355 Check_Arg_Is_Local_Name
(Arg1
);
14356 E_Id
:= Get_Pragma_Arg
(Arg1
);
14358 if Etype
(E_Id
) = Any_Type
then
14362 E
:= Entity
(E_Id
);
14364 if not Is_Record_Type
(E
) then
14366 ("argument for pragma% must be record type", Arg1
);
14369 Ent
:= First_Entity
(E
);
14372 or else No
(Next_Entity
(Ent
))
14373 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14374 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14375 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14378 ("record for pragma% must have two fields of the same "
14379 & "floating-point type", Arg1
);
14382 Set_Has_Complex_Representation
(Base_Type
(E
));
14384 -- We need to treat the type has having a non-standard
14385 -- representation, for back-end purposes, even though in
14386 -- general a complex will have the default representation
14387 -- of a record with two real components.
14389 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14391 end Complex_Representation
;
14393 -------------------------
14394 -- Component_Alignment --
14395 -------------------------
14397 -- pragma Component_Alignment (
14398 -- [Form =>] ALIGNMENT_CHOICE
14399 -- [, [Name =>] type_LOCAL_NAME]);
14401 -- ALIGNMENT_CHOICE ::=
14403 -- | Component_Size_4
14407 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14408 Args
: Args_List
(1 .. 2);
14409 Names
: constant Name_List
(1 .. 2) := (
14413 Form
: Node_Id
renames Args
(1);
14414 Name
: Node_Id
renames Args
(2);
14416 Atype
: Component_Alignment_Kind
;
14421 Gather_Associations
(Names
, Args
);
14424 Error_Pragma
("missing Form argument for pragma%");
14427 Check_Arg_Is_Identifier
(Form
);
14429 -- Get proper alignment, note that Default = Component_Size on all
14430 -- machines we have so far, and we want to set this value rather
14431 -- than the default value to indicate that it has been explicitly
14432 -- set (and thus will not get overridden by the default component
14433 -- alignment for the current scope)
14435 if Chars
(Form
) = Name_Component_Size
then
14436 Atype
:= Calign_Component_Size
;
14438 elsif Chars
(Form
) = Name_Component_Size_4
then
14439 Atype
:= Calign_Component_Size_4
;
14441 elsif Chars
(Form
) = Name_Default
then
14442 Atype
:= Calign_Component_Size
;
14444 elsif Chars
(Form
) = Name_Storage_Unit
then
14445 Atype
:= Calign_Storage_Unit
;
14449 ("invalid Form parameter for pragma%", Form
);
14452 -- The pragma appears in a configuration file
14454 if No
(Parent
(N
)) then
14455 Check_Valid_Configuration_Pragma
;
14457 -- Capture the component alignment in a global variable when
14458 -- the pragma appears in a configuration file. Note that the
14459 -- scope stack is empty at this point and cannot be used to
14460 -- store the alignment value.
14462 Configuration_Component_Alignment
:= Atype
;
14464 -- Case with no name, supplied, affects scope table entry
14466 elsif No
(Name
) then
14468 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14470 -- Case of name supplied
14473 Check_Arg_Is_Local_Name
(Name
);
14475 Typ
:= Entity
(Name
);
14478 or else Rep_Item_Too_Early
(Typ
, N
)
14482 Typ
:= Underlying_Type
(Typ
);
14485 if not Is_Record_Type
(Typ
)
14486 and then not Is_Array_Type
(Typ
)
14489 ("Name parameter of pragma% must identify record or "
14490 & "array type", Name
);
14493 -- An explicit Component_Alignment pragma overrides an
14494 -- implicit pragma Pack, but not an explicit one.
14496 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
14497 Set_Is_Packed
(Base_Type
(Typ
), False);
14498 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
14501 end Component_AlignmentP
;
14503 --------------------------------
14504 -- Constant_After_Elaboration --
14505 --------------------------------
14507 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14509 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
14511 Obj_Decl
: Node_Id
;
14512 Obj_Id
: Entity_Id
;
14516 Check_No_Identifiers
;
14517 Check_At_Most_N_Arguments
(1);
14519 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14521 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
14525 Obj_Id
:= Defining_Entity
(Obj_Decl
);
14527 -- The object declaration must be a library-level variable which
14528 -- is either explicitly initialized or obtains a value during the
14529 -- elaboration of a package body (SPARK RM 3.3.1).
14531 if Ekind
(Obj_Id
) = E_Variable
then
14532 if not Is_Library_Level_Entity
(Obj_Id
) then
14534 ("pragma % must apply to a library level variable");
14537 -- Otherwise the pragma applies to a constant, which is illegal
14540 Error_Pragma
("pragma % must apply to a variable declaration");
14543 -- A pragma that applies to a Ghost entity becomes Ghost for the
14544 -- purposes of legality checks and removal of ignored Ghost code.
14546 Mark_Ghost_Pragma
(N
, Obj_Id
);
14548 -- Chain the pragma on the contract for completeness
14550 Add_Contract_Item
(N
, Obj_Id
);
14552 -- Analyze the Boolean expression (if any)
14554 if Present
(Arg1
) then
14555 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14557 end Constant_After_Elaboration
;
14559 --------------------
14560 -- Contract_Cases --
14561 --------------------
14563 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14565 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14567 -- CASE_GUARD ::= boolean_EXPRESSION | others
14569 -- CONSEQUENCE ::= boolean_EXPRESSION
14571 -- Characteristics:
14573 -- * Analysis - The annotation undergoes initial checks to verify
14574 -- the legal placement and context. Secondary checks preanalyze the
14577 -- Analyze_Contract_Cases_In_Decl_Part
14579 -- * Expansion - The annotation is expanded during the expansion of
14580 -- the related subprogram [body] contract as performed in:
14582 -- Expand_Subprogram_Contract
14584 -- * Template - The annotation utilizes the generic template of the
14585 -- related subprogram [body] when it is:
14587 -- aspect on subprogram declaration
14588 -- aspect on stand-alone subprogram body
14589 -- pragma on stand-alone subprogram body
14591 -- The annotation must prepare its own template when it is:
14593 -- pragma on subprogram declaration
14595 -- * Globals - Capture of global references must occur after full
14598 -- * Instance - The annotation is instantiated automatically when
14599 -- the related generic subprogram [body] is instantiated except for
14600 -- the "pragma on subprogram declaration" case. In that scenario
14601 -- the annotation must instantiate itself.
14603 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14604 Spec_Id
: Entity_Id
;
14605 Subp_Decl
: Node_Id
;
14606 Subp_Spec
: Node_Id
;
14610 Check_No_Identifiers
;
14611 Check_Arg_Count
(1);
14613 -- Ensure the proper placement of the pragma. Contract_Cases must
14614 -- be associated with a subprogram declaration or a body that acts
14618 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14622 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14625 -- Generic subprogram
14627 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14630 -- Body acts as spec
14632 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14633 and then No
(Corresponding_Spec
(Subp_Decl
))
14637 -- Body stub acts as spec
14639 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14640 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14646 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14647 Subp_Spec
:= Specification
(Subp_Decl
);
14649 -- Pragma Contract_Cases is forbidden on null procedures, as
14650 -- this may lead to potential ambiguities in behavior when
14651 -- interface null procedures are involved.
14653 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14654 and then Null_Present
(Subp_Spec
)
14656 Error_Msg_N
(Fix_Error
14657 ("pragma % cannot apply to null procedure"), N
);
14665 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14667 -- A pragma that applies to a Ghost entity becomes Ghost for the
14668 -- purposes of legality checks and removal of ignored Ghost code.
14670 Mark_Ghost_Pragma
(N
, Spec_Id
);
14671 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14673 -- Chain the pragma on the contract for further processing by
14674 -- Analyze_Contract_Cases_In_Decl_Part.
14676 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14678 -- Fully analyze the pragma when it appears inside an entry
14679 -- or subprogram body because it cannot benefit from forward
14682 if Nkind
(Subp_Decl
) in N_Entry_Body
14683 | N_Subprogram_Body
14684 | N_Subprogram_Body_Stub
14686 -- The legality checks of pragma Contract_Cases are affected by
14687 -- the SPARK mode in effect and the volatility of the context.
14688 -- Analyze all pragmas in a specific order.
14690 Analyze_If_Present
(Pragma_SPARK_Mode
);
14691 Analyze_If_Present
(Pragma_Volatile_Function
);
14692 Analyze_Contract_Cases_In_Decl_Part
(N
);
14694 end Contract_Cases
;
14700 -- pragma Controlled (first_subtype_LOCAL_NAME);
14702 when Pragma_Controlled
=> Controlled
: declare
14706 Check_No_Identifiers
;
14707 Check_Arg_Count
(1);
14708 Check_Arg_Is_Local_Name
(Arg1
);
14709 Arg
:= Get_Pragma_Arg
(Arg1
);
14711 if not Is_Entity_Name
(Arg
)
14712 or else not Is_Access_Type
(Entity
(Arg
))
14714 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14716 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14724 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14725 -- [Entity =>] LOCAL_NAME);
14727 when Pragma_Convention
=> Convention
: declare
14730 pragma Warnings
(Off
, C
);
14731 pragma Warnings
(Off
, E
);
14734 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14735 Check_Ada_83_Warning
;
14736 Check_Arg_Count
(2);
14737 Process_Convention
(C
, E
);
14739 -- A pragma that applies to a Ghost entity becomes Ghost for the
14740 -- purposes of legality checks and removal of ignored Ghost code.
14742 Mark_Ghost_Pragma
(N
, E
);
14745 ---------------------------
14746 -- Convention_Identifier --
14747 ---------------------------
14749 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14750 -- [Convention =>] convention_IDENTIFIER);
14752 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14758 Check_Arg_Order
((Name_Name
, Name_Convention
));
14759 Check_Arg_Count
(2);
14760 Check_Optional_Identifier
(Arg1
, Name_Name
);
14761 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14762 Check_Arg_Is_Identifier
(Arg1
);
14763 Check_Arg_Is_Identifier
(Arg2
);
14764 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14765 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14767 if Is_Convention_Name
(Cname
) then
14768 Record_Convention_Identifier
14769 (Idnam
, Get_Convention_Id
(Cname
));
14772 ("second arg for % pragma must be convention", Arg2
);
14774 end Convention_Identifier
;
14780 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14782 when Pragma_CPP_Class
=>
14785 if Warn_On_Obsolescent_Feature
then
14787 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14788 & "effect; replace it by pragma import?j?", N
);
14791 Check_Arg_Count
(1);
14795 Chars
=> Name_Import
,
14796 Pragma_Argument_Associations
=> New_List
(
14797 Make_Pragma_Argument_Association
(Loc
,
14798 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14799 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14802 ---------------------
14803 -- CPP_Constructor --
14804 ---------------------
14806 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14807 -- [, [External_Name =>] static_string_EXPRESSION ]
14808 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14810 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14812 Def_Id
: Entity_Id
;
14813 Tag_Typ
: Entity_Id
;
14817 Check_At_Least_N_Arguments
(1);
14818 Check_At_Most_N_Arguments
(3);
14819 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14820 Check_Arg_Is_Local_Name
(Arg1
);
14822 Id
:= Get_Pragma_Arg
(Arg1
);
14823 Find_Program_Unit_Name
(Id
);
14825 -- If we did not find the name, we are done
14827 if Etype
(Id
) = Any_Type
then
14831 Def_Id
:= Entity
(Id
);
14833 -- Check if already defined as constructor
14835 if Is_Constructor
(Def_Id
) then
14837 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14841 if Ekind
(Def_Id
) = E_Function
14842 and then (Is_CPP_Class
(Etype
(Def_Id
))
14843 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14845 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14847 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14849 ("'C'P'P constructor must be defined in the scope of "
14850 & "its returned type", Arg1
);
14853 if Arg_Count
>= 2 then
14854 Set_Imported
(Def_Id
);
14855 Set_Is_Public
(Def_Id
);
14856 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14859 Set_Has_Completion
(Def_Id
);
14860 Set_Is_Constructor
(Def_Id
);
14861 Set_Convention
(Def_Id
, Convention_CPP
);
14863 -- Imported C++ constructors are not dispatching primitives
14864 -- because in C++ they don't have a dispatch table slot.
14865 -- However, in Ada the constructor has the profile of a
14866 -- function that returns a tagged type and therefore it has
14867 -- been treated as a primitive operation during semantic
14868 -- analysis. We now remove it from the list of primitive
14869 -- operations of the type.
14871 if Is_Tagged_Type
(Etype
(Def_Id
))
14872 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14873 and then Is_Dispatching_Operation
(Def_Id
)
14875 Tag_Typ
:= Etype
(Def_Id
);
14877 Remove
(Primitive_Operations
(Tag_Typ
), Def_Id
);
14878 Set_Is_Dispatching_Operation
(Def_Id
, False);
14881 -- For backward compatibility, if the constructor returns a
14882 -- class wide type, and we internally change the return type to
14883 -- the corresponding root type.
14885 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14886 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14890 ("pragma% requires function returning a 'C'P'P_Class type",
14893 end CPP_Constructor
;
14899 when Pragma_CPP_Virtual
=>
14902 if Warn_On_Obsolescent_Feature
then
14904 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14912 when Pragma_CUDA_Device
=> CUDA_Device
: declare
14913 Arg_Node
: Node_Id
;
14914 Device_Entity
: Entity_Id
;
14917 Check_Arg_Count
(1);
14918 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
14920 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
14921 Device_Entity
:= Entity
(Arg_Node
);
14923 if Ekind
(Device_Entity
) in E_Variable
14928 Add_CUDA_Device_Entity
14929 (Package_Specification_Of_Scope
(Scope
(Device_Entity
)),
14933 Error_Msg_NE
("& must be constant, variable or subprogram",
14944 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
14948 -- [, EXPRESSION]]);
14950 when Pragma_CUDA_Execute
=> CUDA_Execute
: declare
14952 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean;
14953 -- Returns True if N is an acceptable argument for CUDA_Execute,
14954 -- False otherwise.
14956 ------------------------
14957 -- Is_Acceptable_Dim3 --
14958 ------------------------
14960 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean is
14963 if Is_RTE
(Etype
(N
), RE_Dim3
)
14964 or else Is_Integer_Type
(Etype
(N
))
14969 if Nkind
(N
) = N_Aggregate
14970 and then not Null_Record_Present
(N
)
14971 and then No
(Component_Associations
(N
))
14972 and then List_Length
(Expressions
(N
)) = 3
14974 Expr
:= First
(Expressions
(N
));
14975 while Present
(Expr
) loop
14976 Analyze_And_Resolve
(Expr
, Any_Integer
);
14983 end Is_Acceptable_Dim3
;
14987 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg3
);
14988 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
14989 Kernel_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
14990 Shared_Memory
: Node_Id
;
14993 -- Start of processing for CUDA_Execute
14997 Check_At_Least_N_Arguments
(3);
14998 Check_At_Most_N_Arguments
(5);
15000 Analyze_And_Resolve
(Kernel_Call
);
15001 if Nkind
(Kernel_Call
) /= N_Function_Call
15002 or else Etype
(Kernel_Call
) /= Standard_Void_Type
15004 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
15005 -- GNAT sees Kernel_Call as an N_Function_Call since
15006 -- Kernel_Call "looks" like an expression. However, only
15007 -- procedures can be kernels, so to make things easier for the
15008 -- user the error message complains about Kernel_Call not being
15009 -- a procedure call.
15011 Error_Msg_N
("first argument of & must be a procedure call", N
);
15014 Analyze
(Grid_Dimensions
);
15015 if not Is_Acceptable_Dim3
(Grid_Dimensions
) then
15017 ("second argument of & must be an Integer, Dim3 or aggregate "
15018 & "containing 3 Integers", N
);
15021 Analyze
(Block_Dimensions
);
15022 if not Is_Acceptable_Dim3
(Block_Dimensions
) then
15024 ("third argument of & must be an Integer, Dim3 or aggregate "
15025 & "containing 3 Integers", N
);
15028 if Present
(Arg4
) then
15029 Shared_Memory
:= Get_Pragma_Arg
(Arg4
);
15030 Analyze_And_Resolve
(Shared_Memory
, Any_Integer
);
15032 if Present
(Arg5
) then
15033 Stream
:= Get_Pragma_Arg
(Arg5
);
15034 Analyze_And_Resolve
(Stream
, RTE
(RE_Stream_T
));
15043 -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
15045 when Pragma_CUDA_Global
=> CUDA_Global
: declare
15046 Arg_Node
: Node_Id
;
15047 Kernel_Proc
: Entity_Id
;
15048 Pack_Id
: Entity_Id
;
15051 Check_Arg_Count
(1);
15052 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15053 Check_Arg_Is_Local_Name
(Arg1
);
15055 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15056 Analyze
(Arg_Node
);
15058 Kernel_Proc
:= Entity
(Arg_Node
);
15059 Pack_Id
:= Scope
(Kernel_Proc
);
15061 if Ekind
(Kernel_Proc
) /= E_Procedure
then
15062 Error_Msg_NE
("& must be a procedure", N
, Kernel_Proc
);
15064 elsif Ekind
(Pack_Id
) /= E_Package
15065 or else not Is_Library_Level_Entity
(Pack_Id
)
15068 ("& must reside in a library-level package", N
, Kernel_Proc
);
15071 Set_Is_CUDA_Kernel
(Kernel_Proc
);
15072 Add_CUDA_Kernel
(Pack_Id
, Kernel_Proc
);
15080 when Pragma_CPP_Vtable
=>
15083 if Warn_On_Obsolescent_Feature
then
15085 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15093 -- pragma CPU (EXPRESSION);
15095 when Pragma_CPU
=> CPU
: declare
15096 P
: constant Node_Id
:= Parent
(N
);
15102 Check_No_Identifiers
;
15103 Check_Arg_Count
(1);
15104 Arg
:= Get_Pragma_Arg
(Arg1
);
15108 if Nkind
(P
) = N_Subprogram_Body
then
15109 Check_In_Main_Program
;
15111 Analyze_And_Resolve
(Arg
, Any_Integer
);
15113 Ent
:= Defining_Unit_Name
(Specification
(P
));
15115 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15116 Ent
:= Defining_Identifier
(Ent
);
15121 if not Is_OK_Static_Expression
(Arg
) then
15122 Flag_Non_Static_Expr
15123 ("main subprogram affinity is not static!", Arg
);
15126 -- If constraint error, then we already signalled an error
15128 elsif Raises_Constraint_Error
(Arg
) then
15131 -- Otherwise check in range
15135 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15136 -- This is the entity System.Multiprocessors.CPU_Range;
15138 Val
: constant Uint
:= Expr_Value
(Arg
);
15141 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15143 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15146 ("main subprogram CPU is out of range", Arg1
);
15152 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15156 elsif Nkind
(P
) = N_Task_Definition
then
15157 Ent
:= Defining_Identifier
(Parent
(P
));
15159 -- The expression must be analyzed in the special manner
15160 -- described in "Handling of Default and Per-Object
15161 -- Expressions" in sem.ads.
15163 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15165 -- See comment in Sem_Ch13 about the following restrictions
15167 if Is_OK_Static_Expression
(Arg
) then
15168 if Expr_Value
(Arg
) = Uint_0
then
15169 Check_Restriction
(No_Tasks_Unassigned_To_CPU
, N
);
15172 Check_Restriction
(No_Dynamic_CPU_Assignment
, N
);
15175 -- Anything else is incorrect
15181 -- Check duplicate pragma before we chain the pragma in the Rep
15182 -- Item chain of Ent.
15184 Check_Duplicate_Pragma
(Ent
);
15185 Record_Rep_Item
(Ent
, N
);
15188 --------------------
15189 -- Deadline_Floor --
15190 --------------------
15192 -- pragma Deadline_Floor (time_span_EXPRESSION);
15194 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15195 P
: constant Node_Id
:= Parent
(N
);
15201 Check_No_Identifiers
;
15202 Check_Arg_Count
(1);
15204 Arg
:= Get_Pragma_Arg
(Arg1
);
15206 -- The expression must be analyzed in the special manner described
15207 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15209 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15211 -- Only protected types allowed
15213 if Nkind
(P
) /= N_Protected_Definition
then
15217 Ent
:= Defining_Identifier
(Parent
(P
));
15219 -- Check duplicate pragma before we chain the pragma in the Rep
15220 -- Item chain of Ent.
15222 Check_Duplicate_Pragma
(Ent
);
15223 Record_Rep_Item
(Ent
, N
);
15225 end Deadline_Floor
;
15231 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15233 when Pragma_Debug
=> Debug
: declare
15240 -- The condition for executing the call is that the expander
15241 -- is active and that we are not ignoring this debug pragma.
15246 (Expander_Active
and then not Is_Ignored
(N
)),
15249 if not Is_Ignored
(N
) then
15250 Set_SCO_Pragma_Enabled
(Loc
);
15253 if Arg_Count
= 2 then
15255 Make_And_Then
(Loc
,
15256 Left_Opnd
=> Relocate_Node
(Cond
),
15257 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15258 Call
:= Get_Pragma_Arg
(Arg2
);
15260 Call
:= Get_Pragma_Arg
(Arg1
);
15263 if Nkind
(Call
) in N_Expanded_Name
15266 | N_Indexed_Component
15267 | N_Selected_Component
15269 -- If this pragma Debug comes from source, its argument was
15270 -- parsed as a name form (which is syntactically identical).
15271 -- In a generic context a parameterless call will be left as
15272 -- an expanded name (if global) or selected_component if local.
15273 -- Change it to a procedure call statement now.
15275 Change_Name_To_Procedure_Call_Statement
(Call
);
15277 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15279 -- Already in the form of a procedure call statement: nothing
15280 -- to do (could happen in case of an internally generated
15286 -- All other cases: diagnose error
15289 ("argument of pragma ""Debug"" is not procedure call", Call
);
15293 -- Rewrite into a conditional with an appropriate condition. We
15294 -- wrap the procedure call in a block so that overhead from e.g.
15295 -- use of the secondary stack does not generate execution overhead
15296 -- for suppressed conditions.
15298 -- Normally the analysis that follows will freeze the subprogram
15299 -- being called. However, if the call is to a null procedure,
15300 -- we want to freeze it before creating the block, because the
15301 -- analysis that follows may be done with expansion disabled, in
15302 -- which case the body will not be generated, leading to spurious
15305 if Nkind
(Call
) = N_Procedure_Call_Statement
15306 and then Is_Entity_Name
(Name
(Call
))
15308 Analyze
(Name
(Call
));
15309 Freeze_Before
(N
, Entity
(Name
(Call
)));
15313 Make_Implicit_If_Statement
(N
,
15315 Then_Statements
=> New_List
(
15316 Make_Block_Statement
(Loc
,
15317 Handled_Statement_Sequence
=>
15318 Make_Handled_Sequence_Of_Statements
(Loc
,
15319 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15322 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15323 -- after analysis of the normally rewritten node, to capture all
15324 -- references to entities, which avoids issuing wrong warnings
15325 -- about unused entities.
15327 if GNATprove_Mode
then
15328 Rewrite
(N
, Make_Null_Statement
(Loc
));
15336 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15338 when Pragma_Debug_Policy
=>
15340 Check_Arg_Count
(1);
15341 Check_No_Identifiers
;
15342 Check_Arg_Is_Identifier
(Arg1
);
15344 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15345 -- rewrite it that way, and let the rest of the checking come
15346 -- from analyzing the rewritten pragma.
15350 Chars
=> Name_Check_Policy
,
15351 Pragma_Argument_Associations
=> New_List
(
15352 Make_Pragma_Argument_Association
(Loc
,
15353 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15355 Make_Pragma_Argument_Association
(Loc
,
15356 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15359 -------------------------------
15360 -- Default_Initial_Condition --
15361 -------------------------------
15363 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15365 when Pragma_Default_Initial_Condition
=> DIC
: declare
15372 Check_No_Identifiers
;
15373 Check_At_Most_N_Arguments
(2); -- Accounts for implicit type arg
15377 while Present
(Stmt
) loop
15379 -- Skip prior pragmas, but check for duplicates
15381 if Nkind
(Stmt
) = N_Pragma
then
15382 if Pragma_Name
(Stmt
) = Pname
then
15389 -- Skip internally generated code. Note that derived type
15390 -- declarations of untagged types with discriminants are
15391 -- rewritten as private type declarations.
15393 elsif not Comes_From_Source
(Stmt
)
15394 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15398 -- The associated private type [extension] has been found, stop
15401 elsif Nkind
(Stmt
) in N_Private_Extension_Declaration
15402 | N_Private_Type_Declaration
15404 Typ
:= Defining_Entity
(Stmt
);
15407 -- The pragma does not apply to a legal construct, issue an
15408 -- error and stop the analysis.
15414 Stmt
:= Prev
(Stmt
);
15417 -- The pragma does not apply to a legal construct, issue an error
15418 -- and stop the analysis.
15424 -- A pragma that applies to a Ghost entity becomes Ghost for the
15425 -- purposes of legality checks and removal of ignored Ghost code.
15427 Mark_Ghost_Pragma
(N
, Typ
);
15429 -- The pragma signals that the type defines its own DIC assertion
15432 Set_Has_Own_DIC
(Typ
);
15434 -- A type entity argument is appended to facilitate inheriting the
15435 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15436 -- though that extra argument isn't documented for the pragma.
15439 -- When the pragma has no arguments, create an argument with
15440 -- the value Empty, so the type name argument can be appended
15441 -- following it (since it's expected as the second argument).
15444 Set_Pragma_Argument_Associations
(N
, New_List
(
15445 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15446 Expression
=> Empty
)));
15450 (Pragma_Argument_Associations
(N
),
15451 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15452 Expression
=> New_Occurrence_Of
(Typ
, Sloc
(Typ
))));
15455 -- Chain the pragma on the rep item chain for further processing
15457 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15459 -- Create the declaration of the procedure which verifies the
15460 -- assertion expression of pragma DIC at runtime.
15462 Build_DIC_Procedure_Declaration
(Typ
);
15465 ----------------------------------
15466 -- Default_Scalar_Storage_Order --
15467 ----------------------------------
15469 -- pragma Default_Scalar_Storage_Order
15470 -- (High_Order_First | Low_Order_First);
15472 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15473 Default
: Character;
15477 Check_Arg_Count
(1);
15479 -- Default_Scalar_Storage_Order can appear as a configuration
15480 -- pragma, or in a declarative part of a package spec.
15482 if not Is_Configuration_Pragma
then
15483 Check_Is_In_Decl_Part_Or_Package_Spec
;
15486 Check_No_Identifiers
;
15487 Check_Arg_Is_One_Of
15488 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
15489 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15490 Default
:= Fold_Upper
(Name_Buffer
(1));
15492 if not Support_Nondefault_SSO_On_Target
15493 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
15495 if Warn_On_Unrecognized_Pragma
then
15497 ("non-default Scalar_Storage_Order not supported "
15498 & "on target?g?", N
);
15500 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
15503 -- Here set the specified default
15506 Opt
.Default_SSO
:= Default
;
15510 --------------------------
15511 -- Default_Storage_Pool --
15512 --------------------------
15514 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15516 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
15521 Check_Arg_Count
(1);
15523 -- Default_Storage_Pool can appear as a configuration pragma, or
15524 -- in a declarative part of a package spec.
15526 if not Is_Configuration_Pragma
then
15527 Check_Is_In_Decl_Part_Or_Package_Spec
;
15530 if From_Aspect_Specification
(N
) then
15532 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
15534 if not In_Open_Scopes
(E
) then
15536 ("aspect must apply to package or subprogram", N
);
15541 if Present
(Arg1
) then
15542 Pool
:= Get_Pragma_Arg
(Arg1
);
15544 -- Case of Default_Storage_Pool (null);
15546 if Nkind
(Pool
) = N_Null
then
15549 -- This is an odd case, this is not really an expression,
15550 -- so we don't have a type for it. So just set the type to
15553 Set_Etype
(Pool
, Empty
);
15555 -- Case of Default_Storage_Pool (Standard);
15557 elsif Nkind
(Pool
) = N_Identifier
15558 and then Chars
(Pool
) = Name_Standard
15562 if Entity
(Pool
) /= Standard_Standard
then
15564 ("package Standard is not directly visible", Arg1
);
15567 -- Case of Default_Storage_Pool (storage_pool_NAME);
15570 -- If it's a configuration pragma, then the only allowed
15571 -- argument is "null".
15573 if Is_Configuration_Pragma
then
15574 Error_Pragma_Arg
("NULL or Standard expected", Arg1
);
15577 -- The expected type for a non-"null" argument is
15578 -- Root_Storage_Pool'Class, and the pool must be a variable.
15580 Analyze_And_Resolve
15581 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
15583 if Is_Variable
(Pool
) then
15585 -- A pragma that applies to a Ghost entity becomes Ghost
15586 -- for the purposes of legality checks and removal of
15587 -- ignored Ghost code.
15589 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
15593 ("default storage pool must be a variable", Arg1
);
15597 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15598 -- access type will use this information to set the appropriate
15599 -- attributes of the access type. If the pragma appears in a
15600 -- generic unit it is ignored, given that it may refer to a
15603 if not Inside_A_Generic
then
15604 Default_Pool
:= Pool
;
15607 end Default_Storage_Pool
;
15613 -- pragma Depends (DEPENDENCY_RELATION);
15615 -- DEPENDENCY_RELATION ::=
15617 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15619 -- DEPENDENCY_CLAUSE ::=
15620 -- OUTPUT_LIST =>[+] INPUT_LIST
15621 -- | NULL_DEPENDENCY_CLAUSE
15623 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15625 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15627 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15629 -- OUTPUT ::= NAME | FUNCTION_RESULT
15632 -- where FUNCTION_RESULT is a function Result attribute_reference
15634 -- Characteristics:
15636 -- * Analysis - The annotation undergoes initial checks to verify
15637 -- the legal placement and context. Secondary checks fully analyze
15638 -- the dependency clauses in:
15640 -- Analyze_Depends_In_Decl_Part
15642 -- * Expansion - None.
15644 -- * Template - The annotation utilizes the generic template of the
15645 -- related subprogram [body] when it is:
15647 -- aspect on subprogram declaration
15648 -- aspect on stand-alone subprogram body
15649 -- pragma on stand-alone subprogram body
15651 -- The annotation must prepare its own template when it is:
15653 -- pragma on subprogram declaration
15655 -- * Globals - Capture of global references must occur after full
15658 -- * Instance - The annotation is instantiated automatically when
15659 -- the related generic subprogram [body] is instantiated except for
15660 -- the "pragma on subprogram declaration" case. In that scenario
15661 -- the annotation must instantiate itself.
15663 when Pragma_Depends
=> Depends
: declare
15665 Spec_Id
: Entity_Id
;
15666 Subp_Decl
: Node_Id
;
15669 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15673 -- Chain the pragma on the contract for further processing by
15674 -- Analyze_Depends_In_Decl_Part.
15676 Add_Contract_Item
(N
, Spec_Id
);
15678 -- Fully analyze the pragma when it appears inside an entry
15679 -- or subprogram body because it cannot benefit from forward
15682 if Nkind
(Subp_Decl
) in N_Entry_Body
15683 | N_Subprogram_Body
15684 | N_Subprogram_Body_Stub
15686 -- The legality checks of pragmas Depends and Global are
15687 -- affected by the SPARK mode in effect and the volatility
15688 -- of the context. In addition these two pragmas are subject
15689 -- to an inherent order:
15694 -- Analyze all these pragmas in the order outlined above
15696 Analyze_If_Present
(Pragma_SPARK_Mode
);
15697 Analyze_If_Present
(Pragma_Volatile_Function
);
15698 Analyze_If_Present
(Pragma_Global
);
15699 Analyze_Depends_In_Decl_Part
(N
);
15704 ---------------------
15705 -- Detect_Blocking --
15706 ---------------------
15708 -- pragma Detect_Blocking;
15710 when Pragma_Detect_Blocking
=>
15712 Check_Arg_Count
(0);
15713 Check_Valid_Configuration_Pragma
;
15714 Detect_Blocking
:= True;
15716 ------------------------------------
15717 -- Disable_Atomic_Synchronization --
15718 ------------------------------------
15720 -- pragma Disable_Atomic_Synchronization [(Entity)];
15722 when Pragma_Disable_Atomic_Synchronization
=>
15724 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
15726 -------------------
15727 -- Discard_Names --
15728 -------------------
15730 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15732 when Pragma_Discard_Names
=> Discard_Names
: declare
15737 Check_Ada_83_Warning
;
15739 -- Deal with configuration pragma case
15741 if Is_Configuration_Pragma
then
15742 if Arg_Count
/= 0 then
15744 ("nonzero number of arguments for configuration pragma%");
15746 Global_Discard_Names
:= True;
15750 -- Otherwise, check correct appropriate context
15753 Check_Is_In_Decl_Part_Or_Package_Spec
;
15755 if Arg_Count
= 0 then
15757 -- If there is no parameter, then from now on this pragma
15758 -- applies to any enumeration, exception or tagged type
15759 -- defined in the current declarative part, and recursively
15760 -- to any nested scope.
15762 Set_Discard_Names
(Current_Scope
);
15766 Check_Arg_Count
(1);
15767 Check_Optional_Identifier
(Arg1
, Name_On
);
15768 Check_Arg_Is_Local_Name
(Arg1
);
15770 E_Id
:= Get_Pragma_Arg
(Arg1
);
15772 if Etype
(E_Id
) = Any_Type
then
15776 E
:= Entity
(E_Id
);
15778 -- A pragma that applies to a Ghost entity becomes Ghost for
15779 -- the purposes of legality checks and removal of ignored
15782 Mark_Ghost_Pragma
(N
, E
);
15784 if (Is_First_Subtype
(E
)
15786 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
15787 or else Ekind
(E
) = E_Exception
15789 Set_Discard_Names
(E
);
15790 Record_Rep_Item
(E
, N
);
15794 ("inappropriate entity for pragma%", Arg1
);
15800 ------------------------
15801 -- Dispatching_Domain --
15802 ------------------------
15804 -- pragma Dispatching_Domain (EXPRESSION);
15806 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15807 P
: constant Node_Id
:= Parent
(N
);
15813 Check_No_Identifiers
;
15814 Check_Arg_Count
(1);
15816 -- This pragma is born obsolete, but not the aspect
15818 if not From_Aspect_Specification
(N
) then
15820 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15823 if Nkind
(P
) = N_Task_Definition
then
15824 Arg
:= Get_Pragma_Arg
(Arg1
);
15825 Ent
:= Defining_Identifier
(Parent
(P
));
15827 -- A pragma that applies to a Ghost entity becomes Ghost for
15828 -- the purposes of legality checks and removal of ignored Ghost
15831 Mark_Ghost_Pragma
(N
, Ent
);
15833 -- The expression must be analyzed in the special manner
15834 -- described in "Handling of Default and Per-Object
15835 -- Expressions" in sem.ads.
15837 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15839 -- Check duplicate pragma before we chain the pragma in the Rep
15840 -- Item chain of Ent.
15842 Check_Duplicate_Pragma
(Ent
);
15843 Record_Rep_Item
(Ent
, N
);
15845 -- Anything else is incorrect
15850 end Dispatching_Domain
;
15856 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15858 when Pragma_Elaborate
=> Elaborate
: declare
15863 -- Pragma must be in context items list of a compilation unit
15865 if not Is_In_Context_Clause
then
15869 -- Must be at least one argument
15871 if Arg_Count
= 0 then
15872 Error_Pragma
("pragma% requires at least one argument");
15875 -- In Ada 83 mode, there can be no items following it in the
15876 -- context list except other pragmas and implicit with clauses
15877 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15878 -- placement rule does not apply.
15880 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15882 while Present
(Citem
) loop
15883 if Nkind
(Citem
) = N_Pragma
15884 or else (Nkind
(Citem
) = N_With_Clause
15885 and then Implicit_With
(Citem
))
15890 ("(Ada 83) pragma% must be at end of context clause");
15897 -- Finally, the arguments must all be units mentioned in a with
15898 -- clause in the same context clause. Note we already checked (in
15899 -- Par.Prag) that the arguments are all identifiers or selected
15903 Outer
: while Present
(Arg
) loop
15904 Citem
:= First
(List_Containing
(N
));
15905 Inner
: while Citem
/= N
loop
15906 if Nkind
(Citem
) = N_With_Clause
15907 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15909 Set_Elaborate_Present
(Citem
, True);
15910 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15912 -- With the pragma present, elaboration calls on
15913 -- subprograms from the named unit need no further
15914 -- checks, as long as the pragma appears in the current
15915 -- compilation unit. If the pragma appears in some unit
15916 -- in the context, there might still be a need for an
15917 -- Elaborate_All_Desirable from the current compilation
15918 -- to the named unit, so we keep the check enabled. This
15919 -- does not apply in SPARK mode, where we allow pragma
15920 -- Elaborate, but we don't trust it to be right so we
15921 -- will still insist on the Elaborate_All.
15923 if Legacy_Elaboration_Checks
15924 and then In_Extended_Main_Source_Unit
(N
)
15925 and then SPARK_Mode
/= On
15927 Set_Suppress_Elaboration_Warnings
15928 (Entity
(Name
(Citem
)));
15939 ("argument of pragma% is not withed unit", Arg
);
15946 -------------------
15947 -- Elaborate_All --
15948 -------------------
15950 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15952 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15957 Check_Ada_83_Warning
;
15959 -- Pragma must be in context items list of a compilation unit
15961 if not Is_In_Context_Clause
then
15965 -- Must be at least one argument
15967 if Arg_Count
= 0 then
15968 Error_Pragma
("pragma% requires at least one argument");
15971 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15972 -- have to appear at the end of the context clause, but may
15973 -- appear mixed in with other items, even in Ada 83 mode.
15975 -- Final check: the arguments must all be units mentioned in
15976 -- a with clause in the same context clause. Note that we
15977 -- already checked (in Par.Prag) that all the arguments are
15978 -- either identifiers or selected components.
15981 Outr
: while Present
(Arg
) loop
15982 Citem
:= First
(List_Containing
(N
));
15983 Innr
: while Citem
/= N
loop
15984 if Nkind
(Citem
) = N_With_Clause
15985 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15987 Set_Elaborate_All_Present
(Citem
, True);
15988 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15990 -- Suppress warnings and elaboration checks on the named
15991 -- unit if the pragma is in the current compilation, as
15992 -- for pragma Elaborate.
15994 if Legacy_Elaboration_Checks
15995 and then In_Extended_Main_Source_Unit
(N
)
15997 Set_Suppress_Elaboration_Warnings
15998 (Entity
(Name
(Citem
)));
16009 ("argument of pragma% is not withed unit", Arg
);
16016 --------------------
16017 -- Elaborate_Body --
16018 --------------------
16020 -- pragma Elaborate_Body [( library_unit_NAME )];
16022 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
16023 Cunit_Node
: Node_Id
;
16024 Cunit_Ent
: Entity_Id
;
16027 Check_Ada_83_Warning
;
16028 Check_Valid_Library_Unit_Pragma
;
16030 -- If N was rewritten as a null statement there is nothing more
16033 if Nkind
(N
) = N_Null_Statement
then
16037 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16038 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16040 -- A pragma that applies to a Ghost entity becomes Ghost for the
16041 -- purposes of legality checks and removal of ignored Ghost code.
16043 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
16045 if Nkind
(Unit
(Cunit_Node
)) in
16046 N_Package_Body | N_Subprogram_Body
16048 Error_Pragma
("pragma% must refer to a spec, not a body");
16050 Set_Body_Required
(Cunit_Node
);
16051 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
16053 -- If we are in dynamic elaboration mode, then we suppress
16054 -- elaboration warnings for the unit, since it is definitely
16055 -- fine NOT to do dynamic checks at the first level (and such
16056 -- checks will be suppressed because no elaboration boolean
16057 -- is created for Elaborate_Body packages).
16059 -- But in the static model of elaboration, Elaborate_Body is
16060 -- definitely NOT good enough to ensure elaboration safety on
16061 -- its own, since the body may WITH other units that are not
16062 -- safe from an elaboration point of view, so a client must
16063 -- still do an Elaborate_All on such units.
16065 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16066 -- Elaborate_Body always suppressed elab warnings.
16068 if Legacy_Elaboration_Checks
16069 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
16071 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
16074 end Elaborate_Body
;
16076 ------------------------
16077 -- Elaboration_Checks --
16078 ------------------------
16080 -- pragma Elaboration_Checks (Static | Dynamic);
16082 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
16083 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
16084 -- Emit an error if the current context list already contains
16085 -- a previous Elaboration_Checks pragma. This routine raises
16086 -- Pragma_Exit if a duplicate is found.
16088 procedure Ignore_Elaboration_Checks_Pragma
;
16089 -- Warn that the effects of the pragma are ignored. This routine
16090 -- raises Pragma_Exit.
16092 -----------------------------------------------
16093 -- Check_Duplicate_Elaboration_Checks_Pragma --
16094 -----------------------------------------------
16096 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16101 while Present
(Item
) loop
16102 if Nkind
(Item
) = N_Pragma
16103 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16113 end Check_Duplicate_Elaboration_Checks_Pragma
;
16115 --------------------------------------
16116 -- Ignore_Elaboration_Checks_Pragma --
16117 --------------------------------------
16119 procedure Ignore_Elaboration_Checks_Pragma
is
16121 Error_Msg_Name_1
:= Pname
;
16122 Error_Msg_N
("??effects of pragma % are ignored", N
);
16124 ("\place pragma on initial declaration of library unit", N
);
16127 end Ignore_Elaboration_Checks_Pragma
;
16131 Context
: constant Node_Id
:= Parent
(N
);
16134 -- Start of processing for Elaboration_Checks
16138 Check_Arg_Count
(1);
16139 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16141 -- The pragma appears in a configuration file
16143 if No
(Context
) then
16144 Check_Valid_Configuration_Pragma
;
16145 Check_Duplicate_Elaboration_Checks_Pragma
;
16147 -- The pragma acts as a configuration pragma in a compilation unit
16149 -- pragma Elaboration_Checks (...);
16150 -- package Pack is ...;
16152 elsif Nkind
(Context
) = N_Compilation_Unit
16153 and then List_Containing
(N
) = Context_Items
(Context
)
16155 Check_Valid_Configuration_Pragma
;
16156 Check_Duplicate_Elaboration_Checks_Pragma
;
16158 Unt
:= Unit
(Context
);
16160 -- The pragma must appear on the initial declaration of a unit.
16161 -- If this is not the case, warn that the effects of the pragma
16164 if Nkind
(Unt
) = N_Package_Body
then
16165 Ignore_Elaboration_Checks_Pragma
;
16167 -- Check the Acts_As_Spec flag of the compilation units itself
16168 -- to determine whether the subprogram body completes since it
16169 -- has not been analyzed yet. This is safe because compilation
16170 -- units are not overloadable.
16172 elsif Nkind
(Unt
) = N_Subprogram_Body
16173 and then not Acts_As_Spec
(Context
)
16175 Ignore_Elaboration_Checks_Pragma
;
16177 elsif Nkind
(Unt
) = N_Subunit
then
16178 Ignore_Elaboration_Checks_Pragma
;
16181 -- Otherwise the pragma does not appear at the configuration level
16188 -- At this point the pragma is not a duplicate, and appears in the
16189 -- proper context. Set the elaboration model in effect.
16191 Dynamic_Elaboration_Checks
:=
16192 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16193 end Elaboration_Checks
;
16199 -- pragma Eliminate (
16200 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16201 -- [Entity =>] IDENTIFIER |
16202 -- SELECTED_COMPONENT |
16204 -- [, Source_Location => SOURCE_TRACE]);
16206 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16207 -- SOURCE_TRACE ::= STRING_LITERAL
16209 when Pragma_Eliminate
=> Eliminate
: declare
16210 Args
: Args_List
(1 .. 5);
16211 Names
: constant Name_List
(1 .. 5) := (
16214 Name_Parameter_Types
,
16216 Name_Source_Location
);
16218 -- Note : Parameter_Types and Result_Type are leftovers from
16219 -- prior implementations of the pragma. They are not generated
16220 -- by the gnatelim tool, and play no role in selecting which
16221 -- of a set of overloaded names is chosen for elimination.
16223 Unit_Name
: Node_Id
renames Args
(1);
16224 Entity
: Node_Id
renames Args
(2);
16225 Parameter_Types
: Node_Id
renames Args
(3);
16226 Result_Type
: Node_Id
renames Args
(4);
16227 Source_Location
: Node_Id
renames Args
(5);
16231 Check_Valid_Configuration_Pragma
;
16232 Gather_Associations
(Names
, Args
);
16234 if No
(Unit_Name
) then
16235 Error_Pragma
("missing Unit_Name argument for pragma%");
16239 and then (Present
(Parameter_Types
)
16241 Present
(Result_Type
)
16243 Present
(Source_Location
))
16245 Error_Pragma
("missing Entity argument for pragma%");
16248 if (Present
(Parameter_Types
)
16250 Present
(Result_Type
))
16252 Present
(Source_Location
)
16255 ("parameter profile and source location cannot be used "
16256 & "together in pragma%");
16259 Process_Eliminate_Pragma
16268 -----------------------------------
16269 -- Enable_Atomic_Synchronization --
16270 -----------------------------------
16272 -- pragma Enable_Atomic_Synchronization [(Entity)];
16274 when Pragma_Enable_Atomic_Synchronization
=>
16276 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16283 -- [ Convention =>] convention_IDENTIFIER,
16284 -- [ Entity =>] LOCAL_NAME
16285 -- [, [External_Name =>] static_string_EXPRESSION ]
16286 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16288 when Pragma_Export
=> Export
: declare
16290 Def_Id
: Entity_Id
;
16292 pragma Warnings
(Off
, C
);
16295 Check_Ada_83_Warning
;
16299 Name_External_Name
,
16302 Check_At_Least_N_Arguments
(2);
16303 Check_At_Most_N_Arguments
(4);
16305 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16306 -- pragma Export (Entity, "external name");
16308 if Relaxed_RM_Semantics
16309 and then Arg_Count
= 2
16310 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16313 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16316 if not Is_Entity_Name
(Def_Id
) then
16317 Error_Pragma_Arg
("entity name required", Arg1
);
16320 Def_Id
:= Entity
(Def_Id
);
16321 Set_Exported
(Def_Id
, Arg1
);
16324 Process_Convention
(C
, Def_Id
);
16326 -- A pragma that applies to a Ghost entity becomes Ghost for
16327 -- the purposes of legality checks and removal of ignored Ghost
16330 Mark_Ghost_Pragma
(N
, Def_Id
);
16332 if Ekind
(Def_Id
) /= E_Constant
then
16333 Note_Possible_Modification
16334 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16337 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
16338 Set_Exported
(Def_Id
, Arg2
);
16341 -- If the entity is a deferred constant, propagate the information
16342 -- to the full view, because gigi elaborates the full view only.
16344 if Ekind
(Def_Id
) = E_Constant
16345 and then Present
(Full_View
(Def_Id
))
16348 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
16350 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
16351 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
16353 (Id2
, Einfo
.Entities
.Interface_Name
(Def_Id
));
16358 ---------------------
16359 -- Export_Function --
16360 ---------------------
16362 -- pragma Export_Function (
16363 -- [Internal =>] LOCAL_NAME
16364 -- [, [External =>] EXTERNAL_SYMBOL]
16365 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16366 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16367 -- [, [Mechanism =>] MECHANISM]
16368 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16370 -- EXTERNAL_SYMBOL ::=
16372 -- | static_string_EXPRESSION
16374 -- PARAMETER_TYPES ::=
16376 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16378 -- TYPE_DESIGNATOR ::=
16380 -- | subtype_Name ' Access
16384 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16386 -- MECHANISM_ASSOCIATION ::=
16387 -- [formal_parameter_NAME =>] MECHANISM_NAME
16389 -- MECHANISM_NAME ::=
16393 when Pragma_Export_Function
=> Export_Function
: declare
16394 Args
: Args_List
(1 .. 6);
16395 Names
: constant Name_List
(1 .. 6) := (
16398 Name_Parameter_Types
,
16401 Name_Result_Mechanism
);
16403 Internal
: Node_Id
renames Args
(1);
16404 External
: Node_Id
renames Args
(2);
16405 Parameter_Types
: Node_Id
renames Args
(3);
16406 Result_Type
: Node_Id
renames Args
(4);
16407 Mechanism
: Node_Id
renames Args
(5);
16408 Result_Mechanism
: Node_Id
renames Args
(6);
16412 Gather_Associations
(Names
, Args
);
16413 Process_Extended_Import_Export_Subprogram_Pragma
(
16414 Arg_Internal
=> Internal
,
16415 Arg_External
=> External
,
16416 Arg_Parameter_Types
=> Parameter_Types
,
16417 Arg_Result_Type
=> Result_Type
,
16418 Arg_Mechanism
=> Mechanism
,
16419 Arg_Result_Mechanism
=> Result_Mechanism
);
16420 end Export_Function
;
16422 -------------------
16423 -- Export_Object --
16424 -------------------
16426 -- pragma Export_Object (
16427 -- [Internal =>] LOCAL_NAME
16428 -- [, [External =>] EXTERNAL_SYMBOL]
16429 -- [, [Size =>] EXTERNAL_SYMBOL]);
16431 -- EXTERNAL_SYMBOL ::=
16433 -- | static_string_EXPRESSION
16435 -- PARAMETER_TYPES ::=
16437 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16439 -- TYPE_DESIGNATOR ::=
16441 -- | subtype_Name ' Access
16445 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16447 -- MECHANISM_ASSOCIATION ::=
16448 -- [formal_parameter_NAME =>] MECHANISM_NAME
16450 -- MECHANISM_NAME ::=
16454 when Pragma_Export_Object
=> Export_Object
: declare
16455 Args
: Args_List
(1 .. 3);
16456 Names
: constant Name_List
(1 .. 3) := (
16461 Internal
: Node_Id
renames Args
(1);
16462 External
: Node_Id
renames Args
(2);
16463 Size
: Node_Id
renames Args
(3);
16467 Gather_Associations
(Names
, Args
);
16468 Process_Extended_Import_Export_Object_Pragma
(
16469 Arg_Internal
=> Internal
,
16470 Arg_External
=> External
,
16474 ----------------------
16475 -- Export_Procedure --
16476 ----------------------
16478 -- pragma Export_Procedure (
16479 -- [Internal =>] LOCAL_NAME
16480 -- [, [External =>] EXTERNAL_SYMBOL]
16481 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16482 -- [, [Mechanism =>] MECHANISM]);
16484 -- EXTERNAL_SYMBOL ::=
16486 -- | static_string_EXPRESSION
16488 -- PARAMETER_TYPES ::=
16490 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16492 -- TYPE_DESIGNATOR ::=
16494 -- | subtype_Name ' Access
16498 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16500 -- MECHANISM_ASSOCIATION ::=
16501 -- [formal_parameter_NAME =>] MECHANISM_NAME
16503 -- MECHANISM_NAME ::=
16507 when Pragma_Export_Procedure
=> Export_Procedure
: declare
16508 Args
: Args_List
(1 .. 4);
16509 Names
: constant Name_List
(1 .. 4) := (
16512 Name_Parameter_Types
,
16515 Internal
: Node_Id
renames Args
(1);
16516 External
: Node_Id
renames Args
(2);
16517 Parameter_Types
: Node_Id
renames Args
(3);
16518 Mechanism
: Node_Id
renames Args
(4);
16522 Gather_Associations
(Names
, Args
);
16523 Process_Extended_Import_Export_Subprogram_Pragma
(
16524 Arg_Internal
=> Internal
,
16525 Arg_External
=> External
,
16526 Arg_Parameter_Types
=> Parameter_Types
,
16527 Arg_Mechanism
=> Mechanism
);
16528 end Export_Procedure
;
16530 -----------------------------
16531 -- Export_Valued_Procedure --
16532 -----------------------------
16534 -- pragma Export_Valued_Procedure (
16535 -- [Internal =>] LOCAL_NAME
16536 -- [, [External =>] EXTERNAL_SYMBOL,]
16537 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16538 -- [, [Mechanism =>] MECHANISM]);
16540 -- EXTERNAL_SYMBOL ::=
16542 -- | static_string_EXPRESSION
16544 -- PARAMETER_TYPES ::=
16546 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16548 -- TYPE_DESIGNATOR ::=
16550 -- | subtype_Name ' Access
16554 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16556 -- MECHANISM_ASSOCIATION ::=
16557 -- [formal_parameter_NAME =>] MECHANISM_NAME
16559 -- MECHANISM_NAME ::=
16563 when Pragma_Export_Valued_Procedure
=>
16564 Export_Valued_Procedure
: declare
16565 Args
: Args_List
(1 .. 4);
16566 Names
: constant Name_List
(1 .. 4) := (
16569 Name_Parameter_Types
,
16572 Internal
: Node_Id
renames Args
(1);
16573 External
: Node_Id
renames Args
(2);
16574 Parameter_Types
: Node_Id
renames Args
(3);
16575 Mechanism
: Node_Id
renames Args
(4);
16579 Gather_Associations
(Names
, Args
);
16580 Process_Extended_Import_Export_Subprogram_Pragma
(
16581 Arg_Internal
=> Internal
,
16582 Arg_External
=> External
,
16583 Arg_Parameter_Types
=> Parameter_Types
,
16584 Arg_Mechanism
=> Mechanism
);
16585 end Export_Valued_Procedure
;
16587 -------------------
16588 -- Extend_System --
16589 -------------------
16591 -- pragma Extend_System ([Name =>] Identifier);
16593 when Pragma_Extend_System
=>
16595 Check_Valid_Configuration_Pragma
;
16596 Check_Arg_Count
(1);
16597 Check_Optional_Identifier
(Arg1
, Name_Name
);
16598 Check_Arg_Is_Identifier
(Arg1
);
16600 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16603 and then Name_Buffer
(1 .. 4) = "aux_"
16605 if Present
(System_Extend_Pragma_Arg
) then
16606 if Chars
(Get_Pragma_Arg
(Arg1
)) =
16607 Chars
(Expression
(System_Extend_Pragma_Arg
))
16611 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
16612 Error_Pragma
("pragma% conflicts with that #");
16616 System_Extend_Pragma_Arg
:= Arg1
;
16618 if not GNAT_Mode
then
16619 System_Extend_Unit
:= Arg1
;
16623 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
16626 ------------------------
16627 -- Extensions_Allowed --
16628 ------------------------
16630 -- pragma Extensions_Allowed (ON | OFF | ALL);
16632 when Pragma_Extensions_Allowed
=>
16634 Check_Arg_Count
(1);
16635 Check_No_Identifiers
;
16636 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
, Name_All
);
16638 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
16639 Ada_Version
:= Ada_With_Core_Extensions
;
16640 elsif Chars
(Get_Pragma_Arg
(Arg1
)) = Name_All
then
16641 Ada_Version
:= Ada_With_All_Extensions
;
16643 Ada_Version
:= Ada_Version_Explicit
;
16644 Ada_Version_Pragma
:= Empty
;
16647 ------------------------
16648 -- Extensions_Visible --
16649 ------------------------
16651 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16653 -- Characteristics:
16655 -- * Analysis - The annotation is fully analyzed immediately upon
16656 -- elaboration as its expression must be static.
16658 -- * Expansion - None.
16660 -- * Template - The annotation utilizes the generic template of the
16661 -- related subprogram [body] when it is:
16663 -- aspect on subprogram declaration
16664 -- aspect on stand-alone subprogram body
16665 -- pragma on stand-alone subprogram body
16667 -- The annotation must prepare its own template when it is:
16669 -- pragma on subprogram declaration
16671 -- * Globals - Capture of global references must occur after full
16674 -- * Instance - The annotation is instantiated automatically when
16675 -- the related generic subprogram [body] is instantiated except for
16676 -- the "pragma on subprogram declaration" case. In that scenario
16677 -- the annotation must instantiate itself.
16679 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
16680 Formal
: Entity_Id
;
16681 Has_OK_Formal
: Boolean := False;
16682 Spec_Id
: Entity_Id
;
16683 Subp_Decl
: Node_Id
;
16687 Check_No_Identifiers
;
16688 Check_At_Most_N_Arguments
(1);
16691 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16693 -- Abstract subprogram declaration
16695 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
16698 -- Generic subprogram declaration
16700 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16703 -- Body acts as spec
16705 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16706 and then No
(Corresponding_Spec
(Subp_Decl
))
16710 -- Body stub acts as spec
16712 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16713 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16717 -- Subprogram declaration
16719 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16722 -- Otherwise the pragma is associated with an illegal construct
16725 Error_Pragma
("pragma % must apply to a subprogram");
16728 -- Mark the pragma as Ghost if the related subprogram is also
16729 -- Ghost. This also ensures that any expansion performed further
16730 -- below will produce Ghost nodes.
16732 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16733 Mark_Ghost_Pragma
(N
, Spec_Id
);
16735 -- Chain the pragma on the contract for completeness
16737 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16739 -- The legality checks of pragma Extension_Visible are affected
16740 -- by the SPARK mode in effect. Analyze all pragmas in specific
16743 Analyze_If_Present
(Pragma_SPARK_Mode
);
16745 -- Examine the formals of the related subprogram
16747 Formal
:= First_Formal
(Spec_Id
);
16748 while Present
(Formal
) loop
16750 -- At least one of the formals is of a specific tagged type,
16751 -- the pragma is legal.
16753 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
16754 Has_OK_Formal
:= True;
16757 -- A generic subprogram with at least one formal of a private
16758 -- type ensures the legality of the pragma because the actual
16759 -- may be specifically tagged. Note that this is verified by
16760 -- the check above at instantiation time.
16762 elsif Is_Private_Type
(Etype
(Formal
))
16763 and then Is_Generic_Type
(Etype
(Formal
))
16765 Has_OK_Formal
:= True;
16769 Next_Formal
(Formal
);
16772 if not Has_OK_Formal
then
16773 Error_Msg_Name_1
:= Pname
;
16774 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
16776 ("\subprogram & lacks parameter of specific tagged or "
16777 & "generic private type", N
, Spec_Id
);
16782 -- Analyze the Boolean expression (if any)
16784 if Present
(Arg1
) then
16785 Check_Static_Boolean_Expression
16786 (Expression
(Get_Argument
(N
, Spec_Id
)));
16788 end Extensions_Visible
;
16794 -- pragma External (
16795 -- [ Convention =>] convention_IDENTIFIER,
16796 -- [ Entity =>] LOCAL_NAME
16797 -- [, [External_Name =>] static_string_EXPRESSION ]
16798 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16800 when Pragma_External
=> External
: declare
16803 pragma Warnings
(Off
, C
);
16810 Name_External_Name
,
16812 Check_At_Least_N_Arguments
(2);
16813 Check_At_Most_N_Arguments
(4);
16814 Process_Convention
(C
, E
);
16816 -- A pragma that applies to a Ghost entity becomes Ghost for the
16817 -- purposes of legality checks and removal of ignored Ghost code.
16819 Mark_Ghost_Pragma
(N
, E
);
16821 Note_Possible_Modification
16822 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16823 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16824 Set_Exported
(E
, Arg2
);
16827 --------------------------
16828 -- External_Name_Casing --
16829 --------------------------
16831 -- pragma External_Name_Casing (
16832 -- UPPERCASE | LOWERCASE
16833 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16835 when Pragma_External_Name_Casing
=>
16837 Check_No_Identifiers
;
16839 if Arg_Count
= 2 then
16840 Check_Arg_Is_One_Of
16841 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16843 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16845 Opt
.External_Name_Exp_Casing
:= As_Is
;
16847 when Name_Uppercase
=>
16848 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16850 when Name_Lowercase
=>
16851 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16858 Check_Arg_Count
(1);
16861 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16863 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16864 when Name_Uppercase
=>
16865 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16867 when Name_Lowercase
=>
16868 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16878 -- pragma Fast_Math;
16880 when Pragma_Fast_Math
=>
16882 Check_No_Identifiers
;
16883 Check_Valid_Configuration_Pragma
;
16886 --------------------------
16887 -- Favor_Top_Level --
16888 --------------------------
16890 -- pragma Favor_Top_Level (type_NAME);
16892 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16897 Check_No_Identifiers
;
16898 Check_Arg_Count
(1);
16899 Check_Arg_Is_Local_Name
(Arg1
);
16900 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16902 -- A pragma that applies to a Ghost entity becomes Ghost for the
16903 -- purposes of legality checks and removal of ignored Ghost code.
16905 Mark_Ghost_Pragma
(N
, Typ
);
16907 -- If it's an access-to-subprogram type (in particular, not a
16908 -- subtype), set the flag on that type.
16910 if Is_Access_Subprogram_Type
(Typ
) then
16911 Set_Can_Use_Internal_Rep
(Typ
, False);
16913 -- Otherwise it's an error (name denotes the wrong sort of entity)
16917 ("access-to-subprogram type expected",
16918 Get_Pragma_Arg
(Arg1
));
16920 end Favor_Top_Level
;
16922 ---------------------------
16923 -- Finalize_Storage_Only --
16924 ---------------------------
16926 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16928 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16929 Assoc
: constant Node_Id
:= Arg1
;
16930 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16935 Check_No_Identifiers
;
16936 Check_Arg_Count
(1);
16937 Check_Arg_Is_Local_Name
(Arg1
);
16939 Find_Type
(Type_Id
);
16940 Typ
:= Entity
(Type_Id
);
16943 or else Rep_Item_Too_Early
(Typ
, N
)
16947 Typ
:= Underlying_Type
(Typ
);
16950 if not Is_Controlled
(Typ
) then
16951 Error_Pragma
("pragma% must specify controlled type");
16954 Check_First_Subtype
(Arg1
);
16956 if Finalize_Storage_Only
(Typ
) then
16957 Error_Pragma
("duplicate pragma%, only one allowed");
16959 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16960 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16962 end Finalize_Storage
;
16968 -- pragma Ghost [ (boolean_EXPRESSION) ];
16970 when Pragma_Ghost
=> Ghost
: declare
16974 Orig_Stmt
: Node_Id
;
16975 Prev_Id
: Entity_Id
;
16980 Check_No_Identifiers
;
16981 Check_At_Most_N_Arguments
(1);
16985 while Present
(Stmt
) loop
16987 -- Skip prior pragmas, but check for duplicates
16989 if Nkind
(Stmt
) = N_Pragma
then
16990 if Pragma_Name
(Stmt
) = Pname
then
16997 -- Task unit declared without a definition cannot be subject to
16998 -- pragma Ghost (SPARK RM 6.9(19)).
17000 elsif Nkind
(Stmt
) in
17001 N_Single_Task_Declaration | N_Task_Type_Declaration
17003 Error_Pragma
("pragma % cannot apply to a task type");
17005 -- Skip internally generated code
17007 elsif not Comes_From_Source
(Stmt
) then
17008 Orig_Stmt
:= Original_Node
(Stmt
);
17010 -- When pragma Ghost applies to an untagged derivation, the
17011 -- derivation is transformed into a [sub]type declaration.
17014 N_Full_Type_Declaration | N_Subtype_Declaration
17015 and then Comes_From_Source
(Orig_Stmt
)
17016 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
17017 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
17018 N_Derived_Type_Definition
17020 Id
:= Defining_Entity
(Stmt
);
17023 -- When pragma Ghost applies to an object declaration which
17024 -- is initialized by means of a function call that returns
17025 -- on the secondary stack, the object declaration becomes a
17028 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
17029 and then Comes_From_Source
(Orig_Stmt
)
17030 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
17032 Id
:= Defining_Entity
(Stmt
);
17035 -- When pragma Ghost applies to an expression function, the
17036 -- expression function is transformed into a subprogram.
17038 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
17039 and then Comes_From_Source
(Orig_Stmt
)
17040 and then Nkind
(Orig_Stmt
) = N_Expression_Function
17042 Id
:= Defining_Entity
(Stmt
);
17045 -- When pragma Ghost applies to a generic formal type, the
17046 -- type declaration in the instantiation is a generated
17047 -- subtype declaration.
17049 elsif Nkind
(Stmt
) = N_Subtype_Declaration
17050 and then Present
(Generic_Parent_Type
(Stmt
))
17052 Id
:= Defining_Entity
(Stmt
);
17056 -- The pragma applies to a legal construct, stop the traversal
17058 elsif Nkind
(Stmt
) in N_Abstract_Subprogram_Declaration
17059 | N_Formal_Object_Declaration
17060 | N_Formal_Subprogram_Declaration
17061 | N_Formal_Type_Declaration
17062 | N_Full_Type_Declaration
17063 | N_Generic_Subprogram_Declaration
17064 | N_Object_Declaration
17065 | N_Private_Extension_Declaration
17066 | N_Private_Type_Declaration
17067 | N_Subprogram_Declaration
17068 | N_Subtype_Declaration
17070 Id
:= Defining_Entity
(Stmt
);
17073 -- The pragma does not apply to a legal construct, issue an
17074 -- error and stop the analysis.
17078 ("pragma % must apply to an object, package, subprogram "
17082 Stmt
:= Prev
(Stmt
);
17085 Context
:= Parent
(N
);
17087 -- Handle compilation units
17089 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17090 Context
:= Unit
(Parent
(Context
));
17093 -- Protected and task types cannot be subject to pragma Ghost
17094 -- (SPARK RM 6.9(19)).
17096 if Nkind
(Context
) in N_Protected_Body | N_Protected_Definition
17098 Error_Pragma
("pragma % cannot apply to a protected type");
17100 elsif Nkind
(Context
) in N_Task_Body | N_Task_Definition
then
17101 Error_Pragma
("pragma % cannot apply to a task type");
17106 -- When pragma Ghost is associated with a [generic] package, it
17107 -- appears in the visible declarations.
17109 if Nkind
(Context
) = N_Package_Specification
17110 and then Present
(Visible_Declarations
(Context
))
17111 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17113 Id
:= Defining_Entity
(Context
);
17115 -- Pragma Ghost applies to a stand-alone subprogram body
17117 elsif Nkind
(Context
) = N_Subprogram_Body
17118 and then No
(Corresponding_Spec
(Context
))
17120 Id
:= Defining_Entity
(Context
);
17122 -- Pragma Ghost applies to a subprogram declaration that acts
17123 -- as a compilation unit.
17125 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17126 Id
:= Defining_Entity
(Context
);
17128 -- Pragma Ghost applies to a generic subprogram
17130 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17131 Id
:= Defining_Entity
(Specification
(Context
));
17137 ("pragma % must apply to an object, package, subprogram or "
17141 -- Handle completions of types and constants that are subject to
17144 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17145 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17147 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17148 Error_Msg_Name_1
:= Pname
;
17150 -- The full declaration of a deferred constant cannot be
17151 -- subject to pragma Ghost unless the deferred declaration
17152 -- is also Ghost (SPARK RM 6.9(9)).
17154 if Ekind
(Prev_Id
) = E_Constant
then
17155 Error_Msg_Name_1
:= Pname
;
17156 Error_Msg_NE
(Fix_Error
17157 ("pragma % must apply to declaration of deferred "
17158 & "constant &"), N
, Id
);
17161 -- Pragma Ghost may appear on the full view of an incomplete
17162 -- type because the incomplete declaration lacks aspects and
17163 -- cannot be subject to pragma Ghost.
17165 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17168 -- The full declaration of a type cannot be subject to
17169 -- pragma Ghost unless the partial view is also Ghost
17170 -- (SPARK RM 6.9(9)).
17173 Error_Msg_NE
(Fix_Error
17174 ("pragma % must apply to partial view of type &"),
17180 -- A synchronized object cannot be subject to pragma Ghost
17181 -- (SPARK RM 6.9(19)).
17183 elsif Ekind
(Id
) = E_Variable
then
17184 if Is_Protected_Type
(Etype
(Id
)) then
17185 Error_Pragma
("pragma % cannot apply to a protected object");
17187 elsif Is_Task_Type
(Etype
(Id
)) then
17188 Error_Pragma
("pragma % cannot apply to a task object");
17192 -- Analyze the Boolean expression (if any)
17194 if Present
(Arg1
) then
17195 Expr
:= Get_Pragma_Arg
(Arg1
);
17197 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17199 if Is_OK_Static_Expression
(Expr
) then
17201 -- "Ghostness" cannot be turned off once enabled within a
17202 -- region (SPARK RM 6.9(6)).
17204 if Is_False
(Expr_Value
(Expr
))
17205 and then Ghost_Mode
> None
17208 ("pragma % with value False cannot appear in enabled "
17212 -- Otherwise the expression is not static
17216 ("expression of pragma % must be static", Expr
);
17220 Set_Is_Ghost_Entity
(Id
);
17227 -- pragma Global (GLOBAL_SPECIFICATION);
17229 -- GLOBAL_SPECIFICATION ::=
17232 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17234 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17236 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17237 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17238 -- GLOBAL_ITEM ::= NAME
17240 -- Characteristics:
17242 -- * Analysis - The annotation undergoes initial checks to verify
17243 -- the legal placement and context. Secondary checks fully analyze
17244 -- the dependency clauses in:
17246 -- Analyze_Global_In_Decl_Part
17248 -- * Expansion - None.
17250 -- * Template - The annotation utilizes the generic template of the
17251 -- related subprogram [body] when it is:
17253 -- aspect on subprogram declaration
17254 -- aspect on stand-alone subprogram body
17255 -- pragma on stand-alone subprogram body
17257 -- The annotation must prepare its own template when it is:
17259 -- pragma on subprogram declaration
17261 -- * Globals - Capture of global references must occur after full
17264 -- * Instance - The annotation is instantiated automatically when
17265 -- the related generic subprogram [body] is instantiated except for
17266 -- the "pragma on subprogram declaration" case. In that scenario
17267 -- the annotation must instantiate itself.
17269 when Pragma_Global
=> Global
: declare
17271 Spec_Id
: Entity_Id
;
17272 Subp_Decl
: Node_Id
;
17275 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17279 -- Chain the pragma on the contract for further processing by
17280 -- Analyze_Global_In_Decl_Part.
17282 Add_Contract_Item
(N
, Spec_Id
);
17284 -- Fully analyze the pragma when it appears inside an entry
17285 -- or subprogram body because it cannot benefit from forward
17288 if Nkind
(Subp_Decl
) in N_Entry_Body
17289 | N_Subprogram_Body
17290 | N_Subprogram_Body_Stub
17292 -- The legality checks of pragmas Depends and Global are
17293 -- affected by the SPARK mode in effect and the volatility
17294 -- of the context. In addition these two pragmas are subject
17295 -- to an inherent order:
17300 -- Analyze all these pragmas in the order outlined above
17302 Analyze_If_Present
(Pragma_SPARK_Mode
);
17303 Analyze_If_Present
(Pragma_Volatile_Function
);
17304 Analyze_Global_In_Decl_Part
(N
);
17305 Analyze_If_Present
(Pragma_Depends
);
17314 -- pragma Ident (static_string_EXPRESSION)
17316 -- Note: pragma Comment shares this processing. Pragma Ident is
17317 -- identical in effect to pragma Commment.
17319 when Pragma_Comment
17327 Check_Arg_Count
(1);
17328 Check_No_Identifiers
;
17329 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17332 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
17339 GP
:= Parent
(Parent
(N
));
17342 N_Package_Declaration | N_Generic_Package_Declaration
17347 -- If we have a compilation unit, then record the ident value,
17348 -- checking for improper duplication.
17350 if Nkind
(GP
) = N_Compilation_Unit
then
17351 CS
:= Ident_String
(Current_Sem_Unit
);
17353 if Present
(CS
) then
17355 -- If we have multiple instances, concatenate them.
17357 Start_String
(Strval
(CS
));
17358 Store_String_Char
(' ');
17359 Store_String_Chars
(Strval
(Str
));
17360 Set_Strval
(CS
, End_String
);
17363 Set_Ident_String
(Current_Sem_Unit
, Str
);
17366 -- For subunits, we just ignore the Ident, since in GNAT these
17367 -- are not separate object files, and hence not separate units
17368 -- in the unit table.
17370 elsif Nkind
(GP
) = N_Subunit
then
17376 -------------------
17377 -- Ignore_Pragma --
17378 -------------------
17380 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17382 -- Entirely handled in the parser, nothing to do here
17384 when Pragma_Ignore_Pragma
=>
17387 ----------------------------
17388 -- Implementation_Defined --
17389 ----------------------------
17391 -- pragma Implementation_Defined (LOCAL_NAME);
17393 -- Marks previously declared entity as implementation defined. For
17394 -- an overloaded entity, applies to the most recent homonym.
17396 -- pragma Implementation_Defined;
17398 -- The form with no arguments appears anywhere within a scope, most
17399 -- typically a package spec, and indicates that all entities that are
17400 -- defined within the package spec are Implementation_Defined.
17402 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
17407 Check_No_Identifiers
;
17409 -- Form with no arguments
17411 if Arg_Count
= 0 then
17412 Set_Is_Implementation_Defined
(Current_Scope
);
17414 -- Form with one argument
17417 Check_Arg_Count
(1);
17418 Check_Arg_Is_Local_Name
(Arg1
);
17419 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17420 Set_Is_Implementation_Defined
(Ent
);
17422 end Implementation_Defined
;
17428 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17430 -- IMPLEMENTATION_KIND ::=
17431 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17433 -- "By_Any" and "Optional" are treated as synonyms in order to
17434 -- support Ada 2012 aspect Synchronization.
17436 when Pragma_Implemented
=> Implemented
: declare
17437 Proc_Id
: Entity_Id
;
17442 Check_Arg_Count
(2);
17443 Check_No_Identifiers
;
17444 Check_Arg_Is_Identifier
(Arg1
);
17445 Check_Arg_Is_Local_Name
(Arg1
);
17446 Check_Arg_Is_One_Of
(Arg2
,
17449 Name_By_Protected_Procedure
,
17452 -- Extract the name of the local procedure
17454 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17456 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17457 -- primitive procedure of a synchronized tagged type.
17459 if Ekind
(Proc_Id
) = E_Procedure
17460 and then Is_Primitive
(Proc_Id
)
17461 and then Present
(First_Formal
(Proc_Id
))
17463 Typ
:= Etype
(First_Formal
(Proc_Id
));
17465 if Is_Tagged_Type
(Typ
)
17468 -- Check for a protected, a synchronized or a task interface
17470 ((Is_Interface
(Typ
)
17471 and then Is_Synchronized_Interface
(Typ
))
17473 -- Check for a protected type or a task type that implements
17477 (Is_Concurrent_Record_Type
(Typ
)
17478 and then Present
(Interfaces
(Typ
)))
17480 -- In analysis-only mode, examine original protected type
17483 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
17484 and then Present
(Interface_List
(Parent
(Typ
))))
17486 -- Check for a private record extension with keyword
17490 (Ekind
(Typ
) in E_Record_Type_With_Private
17491 | E_Record_Subtype_With_Private
17492 and then Synchronized_Present
(Parent
(Typ
))))
17497 ("controlling formal must be of synchronized tagged type",
17501 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17502 -- By_Protected_Procedure to the primitive procedure of a task
17505 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
17506 and then Is_Interface
(Typ
)
17507 and then Is_Task_Interface
(Typ
)
17510 ("implementation kind By_Protected_Procedure cannot be "
17511 & "applied to a task interface primitive", Arg2
);
17514 -- Procedures declared inside a protected type must be accepted
17516 elsif Ekind
(Proc_Id
) = E_Procedure
17517 and then Is_Protected_Type
(Scope
(Proc_Id
))
17521 -- The first argument is not a primitive procedure
17525 ("pragma % must be applied to a primitive procedure", Arg1
);
17528 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17529 -- By_Protected_Procedure to a procedure that has aspect Yield
17531 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
17532 and then Has_Yield_Aspect
(Proc_Id
)
17535 ("implementation kind By_Protected_Procedure cannot be "
17536 & "applied to entities with aspect 'Yield", Arg2
);
17539 Record_Rep_Item
(Proc_Id
, N
);
17542 ----------------------
17543 -- Implicit_Packing --
17544 ----------------------
17546 -- pragma Implicit_Packing;
17548 when Pragma_Implicit_Packing
=>
17550 Check_Arg_Count
(0);
17551 Implicit_Packing
:= True;
17558 -- [Convention =>] convention_IDENTIFIER,
17559 -- [Entity =>] LOCAL_NAME
17560 -- [, [External_Name =>] static_string_EXPRESSION ]
17561 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17563 when Pragma_Import
=>
17564 Check_Ada_83_Warning
;
17568 Name_External_Name
,
17571 Check_At_Least_N_Arguments
(2);
17572 Check_At_Most_N_Arguments
(4);
17573 Process_Import_Or_Interface
;
17575 ---------------------
17576 -- Import_Function --
17577 ---------------------
17579 -- pragma Import_Function (
17580 -- [Internal =>] LOCAL_NAME,
17581 -- [, [External =>] EXTERNAL_SYMBOL]
17582 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17583 -- [, [Result_Type =>] SUBTYPE_MARK]
17584 -- [, [Mechanism =>] MECHANISM]
17585 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17587 -- EXTERNAL_SYMBOL ::=
17589 -- | static_string_EXPRESSION
17591 -- PARAMETER_TYPES ::=
17593 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17595 -- TYPE_DESIGNATOR ::=
17597 -- | subtype_Name ' Access
17601 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17603 -- MECHANISM_ASSOCIATION ::=
17604 -- [formal_parameter_NAME =>] MECHANISM_NAME
17606 -- MECHANISM_NAME ::=
17610 when Pragma_Import_Function
=> Import_Function
: declare
17611 Args
: Args_List
(1 .. 6);
17612 Names
: constant Name_List
(1 .. 6) := (
17615 Name_Parameter_Types
,
17618 Name_Result_Mechanism
);
17620 Internal
: Node_Id
renames Args
(1);
17621 External
: Node_Id
renames Args
(2);
17622 Parameter_Types
: Node_Id
renames Args
(3);
17623 Result_Type
: Node_Id
renames Args
(4);
17624 Mechanism
: Node_Id
renames Args
(5);
17625 Result_Mechanism
: Node_Id
renames Args
(6);
17629 Gather_Associations
(Names
, Args
);
17630 Process_Extended_Import_Export_Subprogram_Pragma
(
17631 Arg_Internal
=> Internal
,
17632 Arg_External
=> External
,
17633 Arg_Parameter_Types
=> Parameter_Types
,
17634 Arg_Result_Type
=> Result_Type
,
17635 Arg_Mechanism
=> Mechanism
,
17636 Arg_Result_Mechanism
=> Result_Mechanism
);
17637 end Import_Function
;
17639 -------------------
17640 -- Import_Object --
17641 -------------------
17643 -- pragma Import_Object (
17644 -- [Internal =>] LOCAL_NAME
17645 -- [, [External =>] EXTERNAL_SYMBOL]
17646 -- [, [Size =>] EXTERNAL_SYMBOL]);
17648 -- EXTERNAL_SYMBOL ::=
17650 -- | static_string_EXPRESSION
17652 when Pragma_Import_Object
=> Import_Object
: declare
17653 Args
: Args_List
(1 .. 3);
17654 Names
: constant Name_List
(1 .. 3) := (
17659 Internal
: Node_Id
renames Args
(1);
17660 External
: Node_Id
renames Args
(2);
17661 Size
: Node_Id
renames Args
(3);
17665 Gather_Associations
(Names
, Args
);
17666 Process_Extended_Import_Export_Object_Pragma
(
17667 Arg_Internal
=> Internal
,
17668 Arg_External
=> External
,
17672 ----------------------
17673 -- Import_Procedure --
17674 ----------------------
17676 -- pragma Import_Procedure (
17677 -- [Internal =>] LOCAL_NAME
17678 -- [, [External =>] EXTERNAL_SYMBOL]
17679 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17680 -- [, [Mechanism =>] MECHANISM]);
17682 -- EXTERNAL_SYMBOL ::=
17684 -- | static_string_EXPRESSION
17686 -- PARAMETER_TYPES ::=
17688 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17690 -- TYPE_DESIGNATOR ::=
17692 -- | subtype_Name ' Access
17696 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17698 -- MECHANISM_ASSOCIATION ::=
17699 -- [formal_parameter_NAME =>] MECHANISM_NAME
17701 -- MECHANISM_NAME ::=
17705 when Pragma_Import_Procedure
=> Import_Procedure
: declare
17706 Args
: Args_List
(1 .. 4);
17707 Names
: constant Name_List
(1 .. 4) := (
17710 Name_Parameter_Types
,
17713 Internal
: Node_Id
renames Args
(1);
17714 External
: Node_Id
renames Args
(2);
17715 Parameter_Types
: Node_Id
renames Args
(3);
17716 Mechanism
: Node_Id
renames Args
(4);
17720 Gather_Associations
(Names
, Args
);
17721 Process_Extended_Import_Export_Subprogram_Pragma
(
17722 Arg_Internal
=> Internal
,
17723 Arg_External
=> External
,
17724 Arg_Parameter_Types
=> Parameter_Types
,
17725 Arg_Mechanism
=> Mechanism
);
17726 end Import_Procedure
;
17728 -----------------------------
17729 -- Import_Valued_Procedure --
17730 -----------------------------
17732 -- pragma Import_Valued_Procedure (
17733 -- [Internal =>] LOCAL_NAME
17734 -- [, [External =>] EXTERNAL_SYMBOL]
17735 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17736 -- [, [Mechanism =>] MECHANISM]);
17738 -- EXTERNAL_SYMBOL ::=
17740 -- | static_string_EXPRESSION
17742 -- PARAMETER_TYPES ::=
17744 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17746 -- TYPE_DESIGNATOR ::=
17748 -- | subtype_Name ' Access
17752 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17754 -- MECHANISM_ASSOCIATION ::=
17755 -- [formal_parameter_NAME =>] MECHANISM_NAME
17757 -- MECHANISM_NAME ::=
17761 when Pragma_Import_Valued_Procedure
=>
17762 Import_Valued_Procedure
: declare
17763 Args
: Args_List
(1 .. 4);
17764 Names
: constant Name_List
(1 .. 4) := (
17767 Name_Parameter_Types
,
17770 Internal
: Node_Id
renames Args
(1);
17771 External
: Node_Id
renames Args
(2);
17772 Parameter_Types
: Node_Id
renames Args
(3);
17773 Mechanism
: Node_Id
renames Args
(4);
17777 Gather_Associations
(Names
, Args
);
17778 Process_Extended_Import_Export_Subprogram_Pragma
(
17779 Arg_Internal
=> Internal
,
17780 Arg_External
=> External
,
17781 Arg_Parameter_Types
=> Parameter_Types
,
17782 Arg_Mechanism
=> Mechanism
);
17783 end Import_Valued_Procedure
;
17789 -- pragma Independent (LOCAL_NAME);
17791 when Pragma_Independent
=>
17792 Process_Atomic_Independent_Shared_Volatile
;
17794 ----------------------------
17795 -- Independent_Components --
17796 ----------------------------
17798 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17800 when Pragma_Independent_Components
=> Independent_Components
: declare
17807 Check_Ada_83_Warning
;
17809 Check_No_Identifiers
;
17810 Check_Arg_Count
(1);
17811 Check_Arg_Is_Local_Name
(Arg1
);
17812 E_Id
:= Get_Pragma_Arg
(Arg1
);
17814 if Etype
(E_Id
) = Any_Type
then
17818 E
:= Entity
(E_Id
);
17820 -- A record type with a self-referential component of anonymous
17821 -- access type is given an incomplete view in order to handle the
17824 -- type Rec is record
17825 -- Self : access Rec;
17831 -- type Ptr is access Rec;
17832 -- type Rec is record
17836 -- Since the incomplete view is now the initial view of the type,
17837 -- the argument of the pragma will reference the incomplete view,
17838 -- but this view is illegal according to the semantics of the
17841 -- Obtain the full view of an internally-generated incomplete type
17842 -- only. This way an attempt to associate the pragma with a source
17843 -- incomplete type is still caught.
17845 if Ekind
(E
) = E_Incomplete_Type
17846 and then not Comes_From_Source
(E
)
17847 and then Present
(Full_View
(E
))
17849 E
:= Full_View
(E
);
17852 -- A pragma that applies to a Ghost entity becomes Ghost for the
17853 -- purposes of legality checks and removal of ignored Ghost code.
17855 Mark_Ghost_Pragma
(N
, E
);
17857 -- Check duplicate before we chain ourselves
17859 Check_Duplicate_Pragma
(E
);
17861 -- Check appropriate entity
17863 if Rep_Item_Too_Early
(E
, N
)
17865 Rep_Item_Too_Late
(E
, N
)
17870 D
:= Declaration_Node
(E
);
17872 -- The flag is set on the base type, or on the object
17874 if Nkind
(D
) = N_Full_Type_Declaration
17875 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17877 Set_Has_Independent_Components
(Base_Type
(E
));
17878 Record_Independence_Check
(N
, Base_Type
(E
));
17880 -- For record type, set all components independent
17882 if Is_Record_Type
(E
) then
17883 C
:= First_Component
(E
);
17884 while Present
(C
) loop
17885 Set_Is_Independent
(C
);
17886 Next_Component
(C
);
17890 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17891 and then Nkind
(D
) = N_Object_Declaration
17892 and then Nkind
(Object_Definition
(D
)) =
17893 N_Constrained_Array_Definition
17895 Set_Has_Independent_Components
(E
);
17896 Record_Independence_Check
(N
, E
);
17899 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17901 end Independent_Components
;
17903 -----------------------
17904 -- Initial_Condition --
17905 -----------------------
17907 -- pragma Initial_Condition (boolean_EXPRESSION);
17909 -- Characteristics:
17911 -- * Analysis - The annotation undergoes initial checks to verify
17912 -- the legal placement and context. Secondary checks preanalyze the
17915 -- Analyze_Initial_Condition_In_Decl_Part
17917 -- * Expansion - The annotation is expanded during the expansion of
17918 -- the package body whose declaration is subject to the annotation
17921 -- Expand_Pragma_Initial_Condition
17923 -- * Template - The annotation utilizes the generic template of the
17924 -- related package declaration.
17926 -- * Globals - Capture of global references must occur after full
17929 -- * Instance - The annotation is instantiated automatically when
17930 -- the related generic package is instantiated.
17932 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17933 Pack_Decl
: Node_Id
;
17934 Pack_Id
: Entity_Id
;
17938 Check_No_Identifiers
;
17939 Check_Arg_Count
(1);
17941 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17943 if Nkind
(Pack_Decl
) not in
17944 N_Generic_Package_Declaration | N_Package_Declaration
17949 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17951 -- A pragma that applies to a Ghost entity becomes Ghost for the
17952 -- purposes of legality checks and removal of ignored Ghost code.
17954 Mark_Ghost_Pragma
(N
, Pack_Id
);
17956 -- Chain the pragma on the contract for further processing by
17957 -- Analyze_Initial_Condition_In_Decl_Part.
17959 Add_Contract_Item
(N
, Pack_Id
);
17961 -- The legality checks of pragmas Abstract_State, Initializes, and
17962 -- Initial_Condition are affected by the SPARK mode in effect. In
17963 -- addition, these three pragmas are subject to an inherent order:
17965 -- 1) Abstract_State
17967 -- 3) Initial_Condition
17969 -- Analyze all these pragmas in the order outlined above
17971 Analyze_If_Present
(Pragma_SPARK_Mode
);
17972 Analyze_If_Present
(Pragma_Abstract_State
);
17973 Analyze_If_Present
(Pragma_Initializes
);
17974 end Initial_Condition
;
17976 ------------------------
17977 -- Initialize_Scalars --
17978 ------------------------
17980 -- pragma Initialize_Scalars
17981 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17983 -- TYPE_VALUE_PAIR ::=
17984 -- SCALAR_TYPE => static_EXPRESSION
17990 -- | Long_Long_Float
18002 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
18003 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
18004 -- This collection holds the individual pairs which specify the
18005 -- invalid values of their respective scalar types.
18007 procedure Analyze_Float_Value
18008 (Scal_Typ
: Float_Scalar_Id
;
18009 Val_Expr
: Node_Id
);
18010 -- Analyze a type value pair associated with float type Scal_Typ
18011 -- and expression Val_Expr.
18013 procedure Analyze_Integer_Value
18014 (Scal_Typ
: Integer_Scalar_Id
;
18015 Val_Expr
: Node_Id
);
18016 -- Analyze a type value pair associated with integer type Scal_Typ
18017 -- and expression Val_Expr.
18019 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
18020 -- Analyze type value pair Pair
18022 -------------------------
18023 -- Analyze_Float_Value --
18024 -------------------------
18026 procedure Analyze_Float_Value
18027 (Scal_Typ
: Float_Scalar_Id
;
18028 Val_Expr
: Node_Id
)
18031 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
18033 if Is_OK_Static_Expression
(Val_Expr
) then
18034 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
18037 Error_Msg_Name_1
:= Scal_Typ
;
18038 Error_Msg_N
("value for type % must be static", Val_Expr
);
18040 end Analyze_Float_Value
;
18042 ---------------------------
18043 -- Analyze_Integer_Value --
18044 ---------------------------
18046 procedure Analyze_Integer_Value
18047 (Scal_Typ
: Integer_Scalar_Id
;
18048 Val_Expr
: Node_Id
)
18051 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
18053 if (Scal_Typ
= Name_Signed_128
18054 or else Scal_Typ
= Name_Unsigned_128
)
18055 and then Ttypes
.System_Max_Integer_Size
< 128
18057 Error_Msg_Name_1
:= Scal_Typ
;
18058 Error_Msg_N
("value cannot be set for type %", Val_Expr
);
18060 elsif Is_OK_Static_Expression
(Val_Expr
) then
18061 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
18064 Error_Msg_Name_1
:= Scal_Typ
;
18065 Error_Msg_N
("value for type % must be static", Val_Expr
);
18067 end Analyze_Integer_Value
;
18069 -----------------------------
18070 -- Analyze_Type_Value_Pair --
18071 -----------------------------
18073 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
18074 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
18075 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
18076 Prev_Pair
: Node_Id
;
18079 if Scal_Typ
in Scalar_Id
then
18080 Prev_Pair
:= Seen
(Scal_Typ
);
18082 -- Prevent multiple attempts to set a value for a scalar
18085 if Present
(Prev_Pair
) then
18086 Error_Msg_Name_1
:= Scal_Typ
;
18088 ("cannot specify multiple invalid values for type %",
18091 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18092 Error_Msg_N
("previous value set #", Pair
);
18094 -- Ignore the effects of the pair, but do not halt the
18095 -- analysis of the pragma altogether.
18099 -- Otherwise capture the first pair for this scalar type
18102 Seen
(Scal_Typ
) := Pair
;
18105 if Scal_Typ
in Float_Scalar_Id
then
18106 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18108 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18109 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18112 -- Otherwise the scalar family is illegal
18115 Error_Msg_Name_1
:= Pname
;
18117 ("argument of pragma % must denote valid scalar family",
18120 end Analyze_Type_Value_Pair
;
18124 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18127 -- Start of processing for Do_Initialize_Scalars
18131 Check_Valid_Configuration_Pragma
;
18132 Check_Restriction
(No_Initialize_Scalars
, N
);
18134 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18137 if Restriction_Active
(No_Initialize_Scalars
) then
18140 -- Initialize_Scalars creates false positives in CodePeer, and
18141 -- incorrect negative results in GNATprove mode, so ignore this
18142 -- pragma in these modes.
18144 elsif CodePeer_Mode
or GNATprove_Mode
then
18147 -- Otherwise analyze the pragma
18150 if Present
(Pairs
) then
18152 -- Install Standard in order to provide access to primitive
18153 -- types in case the expressions contain attributes such as
18156 Push_Scope
(Standard_Standard
);
18158 Pair
:= First
(Pairs
);
18159 while Present
(Pair
) loop
18160 Analyze_Type_Value_Pair
(Pair
);
18169 Init_Or_Norm_Scalars
:= True;
18170 Initialize_Scalars
:= True;
18172 end Do_Initialize_Scalars
;
18178 -- pragma Initializes (INITIALIZATION_LIST);
18180 -- INITIALIZATION_LIST ::=
18182 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18184 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18189 -- | (INPUT {, INPUT})
18193 -- Characteristics:
18195 -- * Analysis - The annotation undergoes initial checks to verify
18196 -- the legal placement and context. Secondary checks preanalyze the
18199 -- Analyze_Initializes_In_Decl_Part
18201 -- * Expansion - None.
18203 -- * Template - The annotation utilizes the generic template of the
18204 -- related package declaration.
18206 -- * Globals - Capture of global references must occur after full
18209 -- * Instance - The annotation is instantiated automatically when
18210 -- the related generic package is instantiated.
18212 when Pragma_Initializes
=> Initializes
: declare
18213 Pack_Decl
: Node_Id
;
18214 Pack_Id
: Entity_Id
;
18218 Check_No_Identifiers
;
18219 Check_Arg_Count
(1);
18221 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18223 if Nkind
(Pack_Decl
) not in
18224 N_Generic_Package_Declaration | N_Package_Declaration
18229 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18231 -- A pragma that applies to a Ghost entity becomes Ghost for the
18232 -- purposes of legality checks and removal of ignored Ghost code.
18234 Mark_Ghost_Pragma
(N
, Pack_Id
);
18235 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18237 -- Chain the pragma on the contract for further processing by
18238 -- Analyze_Initializes_In_Decl_Part.
18240 Add_Contract_Item
(N
, Pack_Id
);
18242 -- The legality checks of pragmas Abstract_State, Initializes, and
18243 -- Initial_Condition are affected by the SPARK mode in effect. In
18244 -- addition, these three pragmas are subject to an inherent order:
18246 -- 1) Abstract_State
18248 -- 3) Initial_Condition
18250 -- Analyze all these pragmas in the order outlined above
18252 Analyze_If_Present
(Pragma_SPARK_Mode
);
18253 Analyze_If_Present
(Pragma_Abstract_State
);
18254 Analyze_If_Present
(Pragma_Initial_Condition
);
18261 -- pragma Inline ( NAME {, NAME} );
18263 when Pragma_Inline
=>
18265 -- Pragma always active unless in GNATprove mode. It is disabled
18266 -- in GNATprove mode because frontend inlining is applied
18267 -- independently of pragmas Inline and Inline_Always for
18268 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18271 if not GNATprove_Mode
then
18273 -- Inline status is Enabled if option -gnatn is specified.
18274 -- However this status determines only the value of the
18275 -- Is_Inlined flag on the subprogram and does not prevent
18276 -- the pragma itself from being recorded for later use,
18277 -- in particular for a later modification of Is_Inlined
18278 -- independently of the -gnatn option.
18280 -- In other words, if -gnatn is specified for a unit, then
18281 -- all Inline pragmas processed for the compilation of this
18282 -- unit, including those in the spec of other units, are
18283 -- activated, so subprograms will be inlined across units.
18285 -- If -gnatn is not specified, no Inline pragma is activated
18286 -- here, which means that subprograms will not be inlined
18287 -- across units. The Is_Inlined flag will nevertheless be
18288 -- set later when bodies are analyzed, so subprograms will
18289 -- be inlined within the unit.
18291 if Inline_Active
then
18292 Process_Inline
(Enabled
);
18294 Process_Inline
(Disabled
);
18298 -------------------
18299 -- Inline_Always --
18300 -------------------
18302 -- pragma Inline_Always ( NAME {, NAME} );
18304 when Pragma_Inline_Always
=>
18307 -- Pragma always active unless in CodePeer mode or GNATprove
18308 -- mode. It is disabled in CodePeer mode because inlining is
18309 -- not helpful, and enabling it caused walk order issues. It
18310 -- is disabled in GNATprove mode because frontend inlining is
18311 -- applied independently of pragmas Inline and Inline_Always for
18312 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18315 if not CodePeer_Mode
and not GNATprove_Mode
then
18316 Process_Inline
(Enabled
);
18319 --------------------
18320 -- Inline_Generic --
18321 --------------------
18323 -- pragma Inline_Generic (NAME {, NAME});
18325 when Pragma_Inline_Generic
=>
18327 Process_Generic_List
;
18329 ----------------------
18330 -- Inspection_Point --
18331 ----------------------
18333 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18335 when Pragma_Inspection_Point
=> Inspection_Point
: declare
18342 if Arg_Count
> 0 then
18345 Exp
:= Get_Pragma_Arg
(Arg
);
18348 if not Is_Entity_Name
(Exp
)
18349 or else not Is_Object
(Entity
(Exp
))
18351 Error_Pragma_Arg
("object name required", Arg
);
18355 exit when No
(Arg
);
18358 end Inspection_Point
;
18364 -- pragma Interface (
18365 -- [ Convention =>] convention_IDENTIFIER,
18366 -- [ Entity =>] LOCAL_NAME
18367 -- [, [External_Name =>] static_string_EXPRESSION ]
18368 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18370 when Pragma_Interface
=>
18375 Name_External_Name
,
18377 Check_At_Least_N_Arguments
(2);
18378 Check_At_Most_N_Arguments
(4);
18379 Process_Import_Or_Interface
;
18381 -- In Ada 2005, the permission to use Interface (a reserved word)
18382 -- as a pragma name is considered an obsolescent feature, and this
18383 -- pragma was already obsolescent in Ada 95.
18385 if Ada_Version
>= Ada_95
then
18387 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
18389 if Warn_On_Obsolescent_Feature
then
18391 ("pragma Interface is an obsolescent feature?j?", N
);
18393 ("|use pragma Import instead?j?", N
);
18397 --------------------
18398 -- Interface_Name --
18399 --------------------
18401 -- pragma Interface_Name (
18402 -- [ Entity =>] LOCAL_NAME
18403 -- [,[External_Name =>] static_string_EXPRESSION ]
18404 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18406 when Pragma_Interface_Name
=> Interface_Name
: declare
18408 Def_Id
: Entity_Id
;
18409 Hom_Id
: Entity_Id
;
18415 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
18416 Check_At_Least_N_Arguments
(2);
18417 Check_At_Most_N_Arguments
(3);
18418 Id
:= Get_Pragma_Arg
(Arg1
);
18421 -- This is obsolete from Ada 95 on, but it is an implementation
18422 -- defined pragma, so we do not consider that it violates the
18423 -- restriction (No_Obsolescent_Features).
18425 if Ada_Version
>= Ada_95
then
18426 if Warn_On_Obsolescent_Feature
then
18428 ("pragma Interface_Name is an obsolescent feature?j?", N
);
18430 ("|use pragma Import instead?j?", N
);
18434 if not Is_Entity_Name
(Id
) then
18436 ("first argument for pragma% must be entity name", Arg1
);
18437 elsif Etype
(Id
) = Any_Type
then
18440 Def_Id
:= Entity
(Id
);
18443 -- Special DEC-compatible processing for the object case, forces
18444 -- object to be imported.
18446 if Ekind
(Def_Id
) = E_Variable
then
18447 Kill_Size_Check_Code
(Def_Id
);
18448 Note_Possible_Modification
(Id
, Sure
=> False);
18450 -- Initialization is not allowed for imported variable
18452 if Present
(Expression
(Parent
(Def_Id
)))
18453 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
18455 Error_Msg_Sloc
:= Sloc
(Def_Id
);
18457 ("no initialization allowed for declaration of& #",
18461 -- For compatibility, support VADS usage of providing both
18462 -- pragmas Interface and Interface_Name to obtain the effect
18463 -- of a single Import pragma.
18465 if Is_Imported
(Def_Id
)
18466 and then Present
(First_Rep_Item
(Def_Id
))
18467 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
18468 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
18473 Set_Imported
(Def_Id
);
18476 Set_Is_Public
(Def_Id
);
18477 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18480 -- Otherwise must be subprogram
18482 elsif not Is_Subprogram
(Def_Id
) then
18484 ("argument of pragma% is not subprogram", Arg1
);
18487 Check_At_Most_N_Arguments
(3);
18491 -- Loop through homonyms
18494 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
18496 if Is_Imported
(Def_Id
) then
18497 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18501 exit when From_Aspect_Specification
(N
);
18502 Hom_Id
:= Homonym
(Hom_Id
);
18504 exit when No
(Hom_Id
)
18505 or else Scope
(Hom_Id
) /= Current_Scope
;
18510 ("argument of pragma% is not imported subprogram",
18514 end Interface_Name
;
18516 -----------------------
18517 -- Interrupt_Handler --
18518 -----------------------
18520 -- pragma Interrupt_Handler (handler_NAME);
18522 when Pragma_Interrupt_Handler
=>
18523 Check_Ada_83_Warning
;
18524 Check_Arg_Count
(1);
18525 Check_No_Identifiers
;
18527 if No_Run_Time_Mode
then
18528 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
18530 Check_Interrupt_Or_Attach_Handler
;
18531 Process_Interrupt_Or_Attach_Handler
;
18534 ------------------------
18535 -- Interrupt_Priority --
18536 ------------------------
18538 -- pragma Interrupt_Priority [(EXPRESSION)];
18540 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
18541 P
: constant Node_Id
:= Parent
(N
);
18546 Check_Ada_83_Warning
;
18548 if Arg_Count
/= 0 then
18549 Arg
:= Get_Pragma_Arg
(Arg1
);
18550 Check_Arg_Count
(1);
18551 Check_No_Identifiers
;
18553 -- The expression must be analyzed in the special manner
18554 -- described in "Handling of Default and Per-Object
18555 -- Expressions" in sem.ads.
18557 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
18560 if Nkind
(P
) not in N_Task_Definition | N_Protected_Definition
then
18564 Ent
:= Defining_Identifier
(Parent
(P
));
18566 -- Check duplicate pragma before we chain the pragma in the Rep
18567 -- Item chain of Ent.
18569 Check_Duplicate_Pragma
(Ent
);
18570 Record_Rep_Item
(Ent
, N
);
18572 -- Check the No_Task_At_Interrupt_Priority restriction
18574 if Nkind
(P
) = N_Task_Definition
then
18575 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
18578 end Interrupt_Priority
;
18580 ---------------------
18581 -- Interrupt_State --
18582 ---------------------
18584 -- pragma Interrupt_State (
18585 -- [Name =>] INTERRUPT_ID,
18586 -- [State =>] INTERRUPT_STATE);
18588 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18589 -- INTERRUPT_STATE => System | Runtime | User
18591 -- Note: if the interrupt id is given as an identifier, then it must
18592 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18593 -- given as a static integer expression which must be in the range of
18594 -- Ada.Interrupts.Interrupt_ID.
18596 when Pragma_Interrupt_State
=> Interrupt_State
: declare
18597 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
18598 -- This is the entity Ada.Interrupts.Interrupt_ID;
18600 State_Type
: Character;
18601 -- Set to 's'/'r'/'u' for System/Runtime/User
18604 -- Index to entry in Interrupt_States table
18607 -- Value of interrupt
18609 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18610 -- The first argument to the pragma
18612 Int_Ent
: Entity_Id
;
18613 -- Interrupt entity in Ada.Interrupts.Names
18617 Check_Arg_Order
((Name_Name
, Name_State
));
18618 Check_Arg_Count
(2);
18620 Check_Optional_Identifier
(Arg1
, Name_Name
);
18621 Check_Optional_Identifier
(Arg2
, Name_State
);
18622 Check_Arg_Is_Identifier
(Arg2
);
18624 -- First argument is identifier
18626 if Nkind
(Arg1X
) = N_Identifier
then
18628 -- Search list of names in Ada.Interrupts.Names
18630 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
18632 if No
(Int_Ent
) then
18633 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
18635 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
18636 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
18640 Next_Entity
(Int_Ent
);
18643 -- First argument is not an identifier, so it must be a static
18644 -- expression of type Ada.Interrupts.Interrupt_ID.
18647 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
18648 Int_Val
:= Expr_Value
(Arg1X
);
18650 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
18652 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
18655 ("value not in range of type "
18656 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
18662 case Chars
(Get_Pragma_Arg
(Arg2
)) is
18663 when Name_Runtime
=> State_Type
:= 'r';
18664 when Name_System
=> State_Type
:= 's';
18665 when Name_User
=> State_Type
:= 'u';
18668 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
18671 -- Check if entry is already stored
18673 IST_Num
:= Interrupt_States
.First
;
18675 -- If entry not found, add it
18677 if IST_Num
> Interrupt_States
.Last
then
18678 Interrupt_States
.Append
18679 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
18680 Interrupt_State
=> State_Type
,
18681 Pragma_Loc
=> Loc
));
18684 -- Case of entry for the same entry
18686 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
18689 -- If state matches, done, no need to make redundant entry
18692 State_Type
= Interrupt_States
.Table
(IST_Num
).
18695 -- Otherwise if state does not match, error
18698 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
18700 ("state conflicts with that given #", Arg2
);
18703 IST_Num
:= IST_Num
+ 1;
18705 end Interrupt_State
;
18711 -- pragma Invariant
18712 -- ([Entity =>] type_LOCAL_NAME,
18713 -- [Check =>] EXPRESSION
18714 -- [,[Message =>] String_Expression]);
18716 when Pragma_Invariant
=> Invariant
: declare
18723 Check_At_Least_N_Arguments
(2);
18724 Check_At_Most_N_Arguments
(3);
18725 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18726 Check_Optional_Identifier
(Arg2
, Name_Check
);
18728 if Arg_Count
= 3 then
18729 Check_Optional_Identifier
(Arg3
, Name_Message
);
18730 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
18733 Check_Arg_Is_Local_Name
(Arg1
);
18735 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
18736 Find_Type
(Typ_Arg
);
18737 Typ
:= Entity
(Typ_Arg
);
18739 -- Nothing to do of the related type is erroneous in some way
18741 if Typ
= Any_Type
then
18744 -- AI12-0041: Invariants are allowed in interface types
18746 elsif Is_Interface
(Typ
) then
18749 -- An invariant must apply to a private type, or appear in the
18750 -- private part of a package spec and apply to a completion.
18751 -- a class-wide invariant can only appear on a private declaration
18752 -- or private extension, not a completion.
18754 -- A [class-wide] invariant may be associated a [limited] private
18755 -- type or a private extension.
18757 elsif Ekind
(Typ
) in E_Limited_Private_Type
18759 | E_Record_Type_With_Private
18763 -- A non-class-wide invariant may be associated with the full view
18764 -- of a [limited] private type or a private extension.
18766 elsif Has_Private_Declaration
(Typ
)
18767 and then not Class_Present
(N
)
18771 -- A class-wide invariant may appear on the partial view only
18773 elsif Class_Present
(N
) then
18775 ("pragma % only allowed for private type", Arg1
);
18777 -- A regular invariant may appear on both views
18781 ("pragma % only allowed for private type or corresponding "
18782 & "full view", Arg1
);
18785 -- An invariant associated with an abstract type (this includes
18786 -- interfaces) must be class-wide.
18788 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18790 ("pragma % not allowed for abstract type", Arg1
);
18793 -- A pragma that applies to a Ghost entity becomes Ghost for the
18794 -- purposes of legality checks and removal of ignored Ghost code.
18796 Mark_Ghost_Pragma
(N
, Typ
);
18798 -- The pragma defines a type-specific invariant, the type is said
18799 -- to have invariants of its "own".
18801 Set_Has_Own_Invariants
(Base_Type
(Typ
));
18803 -- If the invariant is class-wide, then it can be inherited by
18804 -- derived or interface implementing types. The type is said to
18805 -- have "inheritable" invariants.
18807 if Class_Present
(N
) then
18808 Set_Has_Inheritable_Invariants
(Typ
);
18811 -- Chain the pragma on to the rep item chain, for processing when
18812 -- the type is frozen.
18814 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18816 -- Create the declaration of the invariant procedure that will
18817 -- verify the invariant at run time. Interfaces are treated as the
18818 -- partial view of a private type in order to achieve uniformity
18819 -- with the general case. As a result, an interface receives only
18820 -- a "partial" invariant procedure, which is never called.
18822 Build_Invariant_Procedure_Declaration
18824 Partial_Invariant
=> Is_Interface
(Typ
));
18831 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18833 when Pragma_Keep_Names
=> Keep_Names
: declare
18838 Check_Arg_Count
(1);
18839 Check_Optional_Identifier
(Arg1
, Name_On
);
18840 Check_Arg_Is_Local_Name
(Arg1
);
18842 Arg
:= Get_Pragma_Arg
(Arg1
);
18845 if Etype
(Arg
) = Any_Type
then
18849 if not Is_Entity_Name
(Arg
)
18850 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18853 ("pragma% requires a local enumeration type", Arg1
);
18856 Set_Discard_Names
(Entity
(Arg
), False);
18863 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18865 when Pragma_License
=>
18868 -- Do not analyze pragma any further in CodePeer mode, to avoid
18869 -- extraneous errors in this implementation-dependent pragma,
18870 -- which has a different profile on other compilers.
18872 if CodePeer_Mode
then
18876 Check_Arg_Count
(1);
18877 Check_No_Identifiers
;
18878 Check_Valid_Configuration_Pragma
;
18879 Check_Arg_Is_Identifier
(Arg1
);
18882 Sind
: constant Source_File_Index
:=
18883 Source_Index
(Current_Sem_Unit
);
18886 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18888 Set_License
(Sind
, GPL
);
18890 when Name_Modified_GPL
=>
18891 Set_License
(Sind
, Modified_GPL
);
18893 when Name_Restricted
=>
18894 Set_License
(Sind
, Restricted
);
18896 when Name_Unrestricted
=>
18897 Set_License
(Sind
, Unrestricted
);
18900 Error_Pragma_Arg
("invalid license name", Arg1
);
18908 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18910 when Pragma_Link_With
=> Link_With
: declare
18916 if Operating_Mode
= Generate_Code
18917 and then In_Extended_Main_Source_Unit
(N
)
18919 Check_At_Least_N_Arguments
(1);
18920 Check_No_Identifiers
;
18921 Check_Is_In_Decl_Part_Or_Package_Spec
;
18922 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18926 while Present
(Arg
) loop
18927 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18929 -- Store argument, converting sequences of spaces to a
18930 -- single null character (this is one of the differences
18931 -- in processing between Link_With and Linker_Options).
18933 Arg_Store
: declare
18934 C
: constant Char_Code
:= Get_Char_Code
(' ');
18935 S
: constant String_Id
:=
18936 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18937 L
: constant Nat
:= String_Length
(S
);
18940 procedure Skip_Spaces
;
18941 -- Advance F past any spaces
18947 procedure Skip_Spaces
is
18949 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18954 -- Start of processing for Arg_Store
18957 Skip_Spaces
; -- skip leading spaces
18959 -- Loop through characters, changing any embedded
18960 -- sequence of spaces to a single null character (this
18961 -- is how Link_With/Linker_Options differ)
18964 if Get_String_Char
(S
, F
) = C
then
18967 Store_String_Char
(ASCII
.NUL
);
18970 Store_String_Char
(Get_String_Char
(S
, F
));
18978 if Present
(Arg
) then
18979 Store_String_Char
(ASCII
.NUL
);
18983 Store_Linker_Option_String
(End_String
);
18991 -- pragma Linker_Alias (
18992 -- [Entity =>] LOCAL_NAME
18993 -- [Target =>] static_string_EXPRESSION);
18995 when Pragma_Linker_Alias
=>
18997 Check_Arg_Order
((Name_Entity
, Name_Target
));
18998 Check_Arg_Count
(2);
18999 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19000 Check_Optional_Identifier
(Arg2
, Name_Target
);
19001 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19002 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19004 -- The only processing required is to link this item on to the
19005 -- list of rep items for the given entity. This is accomplished
19006 -- by the call to Rep_Item_Too_Late (when no error is detected
19007 -- and False is returned).
19009 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
19012 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19015 ------------------------
19016 -- Linker_Constructor --
19017 ------------------------
19019 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19021 -- Code is shared with Linker_Destructor
19023 -----------------------
19024 -- Linker_Destructor --
19025 -----------------------
19027 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19029 when Pragma_Linker_Constructor
19030 | Pragma_Linker_Destructor
19032 Linker_Constructor
: declare
19038 Check_Arg_Count
(1);
19039 Check_No_Identifiers
;
19040 Check_Arg_Is_Local_Name
(Arg1
);
19041 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
19043 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
19045 if not Is_Library_Level_Entity
(Proc
) then
19047 ("argument for pragma% must be library level entity", Arg1
);
19050 -- The only processing required is to link this item on to the
19051 -- list of rep items for the given entity. This is accomplished
19052 -- by the call to Rep_Item_Too_Late (when no error is detected
19053 -- and False is returned).
19055 if Rep_Item_Too_Late
(Proc
, N
) then
19058 Set_Has_Gigi_Rep_Item
(Proc
);
19060 end Linker_Constructor
;
19062 --------------------
19063 -- Linker_Options --
19064 --------------------
19066 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19068 when Pragma_Linker_Options
=> Linker_Options
: declare
19072 Check_Ada_83_Warning
;
19073 Check_No_Identifiers
;
19074 Check_Arg_Count
(1);
19075 Check_Is_In_Decl_Part_Or_Package_Spec
;
19076 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19077 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
19080 while Present
(Arg
) loop
19081 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19082 Store_String_Char
(ASCII
.NUL
);
19084 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19088 if Operating_Mode
= Generate_Code
19089 and then In_Extended_Main_Source_Unit
(N
)
19091 Store_Linker_Option_String
(End_String
);
19093 end Linker_Options
;
19095 --------------------
19096 -- Linker_Section --
19097 --------------------
19099 -- pragma Linker_Section (
19100 -- [Entity =>] LOCAL_NAME
19101 -- [Section =>] static_string_EXPRESSION);
19103 when Pragma_Linker_Section
=> Linker_Section
: declare
19108 Ghost_Error_Posted
: Boolean := False;
19109 -- Flag set when an error concerning the illegal mix of Ghost and
19110 -- non-Ghost subprograms is emitted.
19112 Ghost_Id
: Entity_Id
:= Empty
;
19113 -- The entity of the first Ghost subprogram encountered while
19114 -- processing the arguments of the pragma.
19118 Check_Arg_Order
((Name_Entity
, Name_Section
));
19119 Check_Arg_Count
(2);
19120 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19121 Check_Optional_Identifier
(Arg2
, Name_Section
);
19122 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19123 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19125 -- Check kind of entity
19127 Arg
:= Get_Pragma_Arg
(Arg1
);
19128 Ent
:= Entity
(Arg
);
19130 case Ekind
(Ent
) is
19132 -- Objects (constants and variables) and types. For these cases
19133 -- all we need to do is to set the Linker_Section_pragma field,
19134 -- checking that we do not have a duplicate.
19140 LPE
:= Linker_Section_Pragma
(Ent
);
19142 if Present
(LPE
) then
19143 Error_Msg_Sloc
:= Sloc
(LPE
);
19145 ("Linker_Section already specified for &#", Arg1
, Ent
);
19148 Set_Linker_Section_Pragma
(Ent
, N
);
19150 -- A pragma that applies to a Ghost entity becomes Ghost for
19151 -- the purposes of legality checks and removal of ignored
19154 Mark_Ghost_Pragma
(N
, Ent
);
19158 when Subprogram_Kind
=>
19160 -- Aspect case, entity already set
19162 if From_Aspect_Specification
(N
) then
19163 Set_Linker_Section_Pragma
19164 (Entity
(Corresponding_Aspect
(N
)), N
);
19166 -- Propagate it to its ultimate aliased entity to
19167 -- facilitate the backend processing this attribute
19168 -- in instantiations of generic subprograms.
19170 if Present
(Alias
(Entity
(Corresponding_Aspect
(N
))))
19172 Set_Linker_Section_Pragma
19174 (Entity
(Corresponding_Aspect
(N
))), N
);
19177 -- Pragma case, we must climb the homonym chain, but skip
19178 -- any for which the linker section is already set.
19182 if No
(Linker_Section_Pragma
(Ent
)) then
19183 Set_Linker_Section_Pragma
(Ent
, N
);
19185 -- Propagate it to its ultimate aliased entity to
19186 -- facilitate the backend processing this attribute
19187 -- in instantiations of generic subprograms.
19189 if Present
(Alias
(Ent
)) then
19190 Set_Linker_Section_Pragma
19191 (Ultimate_Alias
(Ent
), N
);
19194 -- A pragma that applies to a Ghost entity becomes
19195 -- Ghost for the purposes of legality checks and
19196 -- removal of ignored Ghost code.
19198 Mark_Ghost_Pragma
(N
, Ent
);
19200 -- Capture the entity of the first Ghost subprogram
19201 -- being processed for error detection purposes.
19203 if Is_Ghost_Entity
(Ent
) then
19204 if No
(Ghost_Id
) then
19208 -- Otherwise the subprogram is non-Ghost. It is
19209 -- illegal to mix references to Ghost and non-Ghost
19210 -- entities (SPARK RM 6.9).
19212 elsif Present
(Ghost_Id
)
19213 and then not Ghost_Error_Posted
19215 Ghost_Error_Posted
:= True;
19217 Error_Msg_Name_1
:= Pname
;
19219 ("pragma % cannot mention ghost and "
19220 & "non-ghost subprograms", N
);
19222 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19224 ("\& # declared as ghost", N
, Ghost_Id
);
19226 Error_Msg_Sloc
:= Sloc
(Ent
);
19228 ("\& # declared as non-ghost", N
, Ent
);
19232 Ent
:= Homonym
(Ent
);
19234 or else Scope
(Ent
) /= Current_Scope
;
19238 -- All other cases are illegal
19242 ("pragma% applies only to objects, subprograms, and types",
19245 end Linker_Section
;
19251 -- pragma List (On | Off)
19253 -- There is nothing to do here, since we did all the processing for
19254 -- this pragma in Par.Prag (so that it works properly even in syntax
19257 when Pragma_List
=>
19264 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19266 when Pragma_Lock_Free
=> Lock_Free
: declare
19267 P
: constant Node_Id
:= Parent
(N
);
19273 Check_No_Identifiers
;
19274 Check_At_Most_N_Arguments
(1);
19276 -- Protected definition case
19278 if Nkind
(P
) = N_Protected_Definition
then
19279 Ent
:= Defining_Identifier
(Parent
(P
));
19283 if Arg_Count
= 1 then
19284 Arg
:= Get_Pragma_Arg
(Arg1
);
19285 Val
:= Is_True
(Static_Boolean
(Arg
));
19287 -- No arguments (expression is considered to be True)
19293 -- Check duplicate pragma before we chain the pragma in the Rep
19294 -- Item chain of Ent.
19296 Check_Duplicate_Pragma
(Ent
);
19297 Record_Rep_Item
(Ent
, N
);
19298 Set_Uses_Lock_Free
(Ent
, Val
);
19300 -- Anything else is incorrect placement
19307 --------------------
19308 -- Locking_Policy --
19309 --------------------
19311 -- pragma Locking_Policy (policy_IDENTIFIER);
19313 when Pragma_Locking_Policy
=> declare
19314 subtype LP_Range
is Name_Id
19315 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
19320 Check_Ada_83_Warning
;
19321 Check_Arg_Count
(1);
19322 Check_No_Identifiers
;
19323 Check_Arg_Is_Locking_Policy
(Arg1
);
19324 Check_Valid_Configuration_Pragma
;
19325 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19328 when Name_Ceiling_Locking
=> LP
:= 'C';
19329 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
19330 when Name_Inheritance_Locking
=> LP
:= 'I';
19333 if Locking_Policy
/= ' '
19334 and then Locking_Policy
/= LP
19336 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19337 Error_Pragma
("locking policy incompatible with policy#");
19339 -- Set new policy, but always preserve System_Location since we
19340 -- like the error message with the run time name.
19343 Locking_Policy
:= LP
;
19345 if Locking_Policy_Sloc
/= System_Location
then
19346 Locking_Policy_Sloc
:= Loc
;
19351 -------------------
19352 -- Loop_Optimize --
19353 -------------------
19355 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19357 -- OPTIMIZATION_HINT ::=
19358 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19360 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
19365 Check_At_Least_N_Arguments
(1);
19366 Check_No_Identifiers
;
19368 Hint
:= First
(Pragma_Argument_Associations
(N
));
19369 while Present
(Hint
) loop
19370 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
19378 Check_Loop_Pragma_Placement
;
19385 -- pragma Loop_Variant
19386 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19388 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19390 -- CHANGE_DIRECTION ::= Increases | Decreases
19392 when Pragma_Loop_Variant
=> Loop_Variant
: declare
19397 Check_At_Least_N_Arguments
(1);
19398 Check_Loop_Pragma_Placement
;
19400 -- Process all increasing / decreasing expressions
19402 Variant
:= First
(Pragma_Argument_Associations
(N
));
19403 while Present
(Variant
) loop
19404 if Chars
(Variant
) = No_Name
then
19405 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
19407 elsif Chars
(Variant
) not in
19408 Name_Decreases | Name_Increases | Name_Structural
19411 Name
: String := Get_Name_String
(Chars
(Variant
));
19414 -- It is a common mistake to write "Increasing" for
19415 -- "Increases" or "Decreasing" for "Decreases". Recognize
19416 -- specially names starting with "incr" or "decr" to
19417 -- suggest the corresponding name.
19419 System
.Case_Util
.To_Lower
(Name
);
19421 if Name
'Length >= 4
19422 and then Name
(1 .. 4) = "incr"
19424 Error_Pragma_Arg_Ident
19425 ("expect name `Increases`", Variant
);
19427 elsif Name
'Length >= 4
19428 and then Name
(1 .. 4) = "decr"
19430 Error_Pragma_Arg_Ident
19431 ("expect name `Decreases`", Variant
);
19433 elsif Name
'Length >= 4
19434 and then Name
(1 .. 4) = "stru"
19436 Error_Pragma_Arg_Ident
19437 ("expect name `Structural`", Variant
);
19440 Error_Pragma_Arg_Ident
19441 ("expect name `Increases`, `Decreases`,"
19442 & " or `Structural`", Variant
);
19446 elsif Chars
(Variant
) = Name_Structural
19447 and then List_Length
(Pragma_Argument_Associations
(N
)) > 1
19449 Error_Pragma_Arg_Ident
19450 ("Structural variant shall be the only variant", Variant
);
19453 -- Preanalyze_Assert_Expression, but without enforcing any of
19454 -- the two acceptable types.
19456 Preanalyze_Assert_Expression
(Expression
(Variant
));
19458 -- Expression of a discrete type is allowed. Nothing to
19459 -- check for structural variants.
19461 if Chars
(Variant
) = Name_Structural
19462 or else Is_Discrete_Type
(Etype
(Expression
(Variant
)))
19466 -- Expression of a Big_Integer type (or its ghost variant) is
19467 -- only allowed in Decreases clause.
19470 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
19473 Is_RTE
(Base_Type
(Etype
(Expression
(Variant
))),
19476 if Chars
(Variant
) = Name_Increases
then
19478 ("Loop_Variant with Big_Integer can only decrease",
19479 Expression
(Variant
));
19482 -- Expression of other types is not allowed
19486 ("expected a discrete or Big_Integer type",
19487 Expression
(Variant
));
19494 -----------------------
19495 -- Machine_Attribute --
19496 -----------------------
19498 -- pragma Machine_Attribute (
19499 -- [Entity =>] LOCAL_NAME,
19500 -- [Attribute_Name =>] static_string_EXPRESSION
19501 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19503 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
19505 Def_Id
: Entity_Id
;
19509 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
19511 if Arg_Count
>= 3 then
19512 Check_Optional_Identifier
(Arg3
, Name_Info
);
19514 while Present
(Arg
) loop
19515 Check_Arg_Is_OK_Static_Expression
(Arg
);
19519 Check_Arg_Count
(2);
19522 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19523 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
19524 Check_Arg_Is_Local_Name
(Arg1
);
19525 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19526 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
19528 -- Apply the pragma to the designated type, rather than to the
19529 -- access type, unless it's a strub annotation. We wish to enable
19530 -- objects of access type, as well as access types themselves, to
19531 -- be annotated, so that reading the access objects (as oposed to
19532 -- the designated data) automatically enables stack
19533 -- scrubbing. That said, as in the attribute handler that
19534 -- processes the pragma turned into a compiler attribute, a strub
19535 -- annotation that must be associated with a subprogram type (for
19536 -- holding an explicit strub mode), when applied to an
19537 -- access-to-subprogram, gets promoted to the subprogram type. We
19538 -- might be tempted to leave it alone here, since the C attribute
19539 -- handler will adjust it, but then GNAT would convert the
19540 -- annotated subprogram types to naked ones before using them,
19541 -- cancelling out their intended effects.
19543 if Is_Access_Type
(Def_Id
)
19544 and then (not Strub_Pragma_P
(N
)
19548 Ekind
(Designated_Type
19549 (Def_Id
)) = E_Subprogram_Type
))
19551 Def_Id
:= Designated_Type
(Def_Id
);
19554 if Rep_Item_Too_Early
(Def_Id
, N
) then
19558 Def_Id
:= Underlying_Type
(Def_Id
);
19560 -- The only processing required is to link this item on to the
19561 -- list of rep items for the given entity. This is accomplished
19562 -- by the call to Rep_Item_Too_Late (when no error is detected
19563 -- and False is returned).
19565 if Rep_Item_Too_Late
(Def_Id
, N
) then
19568 Set_Has_Gigi_Rep_Item
(Def_Id
);
19570 end Machine_Attribute
;
19577 -- (MAIN_OPTION [, MAIN_OPTION]);
19580 -- [STACK_SIZE =>] static_integer_EXPRESSION
19581 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19582 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19584 when Pragma_Main
=> Main
: declare
19585 Args
: Args_List
(1 .. 3);
19586 Names
: constant Name_List
(1 .. 3) := (
19588 Name_Task_Stack_Size_Default
,
19589 Name_Time_Slicing_Enabled
);
19595 Gather_Associations
(Names
, Args
);
19597 for J
in 1 .. 2 loop
19598 if Present
(Args
(J
)) then
19599 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19603 if Present
(Args
(3)) then
19604 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
19608 while Present
(Nod
) loop
19609 if Nkind
(Nod
) = N_Pragma
19610 and then Pragma_Name
(Nod
) = Name_Main
19612 Error_Msg_Name_1
:= Pname
;
19613 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19624 -- pragma Main_Storage
19625 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19627 -- MAIN_STORAGE_OPTION ::=
19628 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19629 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19631 when Pragma_Main_Storage
=> Main_Storage
: declare
19632 Args
: Args_List
(1 .. 2);
19633 Names
: constant Name_List
(1 .. 2) := (
19634 Name_Working_Storage
,
19641 Gather_Associations
(Names
, Args
);
19643 for J
in 1 .. 2 loop
19644 if Present
(Args
(J
)) then
19645 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19649 Check_In_Main_Program
;
19652 while Present
(Nod
) loop
19653 if Nkind
(Nod
) = N_Pragma
19654 and then Pragma_Name
(Nod
) = Name_Main_Storage
19656 Error_Msg_Name_1
:= Pname
;
19657 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19664 ----------------------------
19665 -- Max_Entry_Queue_Length --
19666 ----------------------------
19668 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19670 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19671 -- Pragma_Max_Queue_Length.
19673 when Pragma_Max_Entry_Queue_Length
19674 | Pragma_Max_Entry_Queue_Depth
19675 | Pragma_Max_Queue_Length
19677 Max_Entry_Queue_Length
: declare
19679 Entry_Decl
: Node_Id
;
19680 Entry_Id
: Entity_Id
;
19684 if Prag_Id
= Pragma_Max_Entry_Queue_Depth
19685 or else Prag_Id
= Pragma_Max_Queue_Length
19690 Check_Arg_Count
(1);
19693 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
19695 -- Entry declaration
19697 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
19699 -- Entry illegally within a task
19701 if Nkind
(Parent
(N
)) = N_Task_Definition
then
19702 Error_Pragma
("pragma % cannot apply to task entries");
19705 Entry_Id
:= Defining_Entity
(Entry_Decl
);
19707 -- Otherwise the pragma is associated with an illegal construct
19711 ("pragma % must apply to a protected entry declaration");
19714 -- Mark the pragma as Ghost if the related subprogram is also
19715 -- Ghost. This also ensures that any expansion performed further
19716 -- below will produce Ghost nodes.
19718 Mark_Ghost_Pragma
(N
, Entry_Id
);
19720 -- Analyze the Integer expression
19722 Arg
:= Get_Pragma_Arg
(Arg1
);
19723 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
19725 Val
:= Expr_Value
(Arg
);
19729 ("argument for pragma% cannot be less than -1", Arg1
);
19731 elsif not UI_Is_In_Int_Range
(Val
) then
19733 ("argument for pragma% out of range of Integer", Arg1
);
19737 Record_Rep_Item
(Entry_Id
, N
);
19738 end Max_Entry_Queue_Length
;
19744 -- pragma Memory_Size (NUMERIC_LITERAL)
19746 when Pragma_Memory_Size
=>
19749 -- Memory size is simply ignored
19751 Check_No_Identifiers
;
19752 Check_Arg_Count
(1);
19753 Check_Arg_Is_Integer_Literal
(Arg1
);
19761 -- The only correct use of this pragma is on its own in a file, in
19762 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19763 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19764 -- check for a file containing nothing but a No_Body pragma). If we
19765 -- attempt to process it during normal semantics processing, it means
19766 -- it was misplaced.
19768 when Pragma_No_Body
=>
19772 -----------------------------
19773 -- No_Elaboration_Code_All --
19774 -----------------------------
19776 -- pragma No_Elaboration_Code_All;
19778 when Pragma_No_Elaboration_Code_All
=>
19780 Check_Valid_Library_Unit_Pragma
;
19782 -- If N was rewritten as a null statement there is nothing more
19785 if Nkind
(N
) = N_Null_Statement
then
19789 -- Must appear for a spec or generic spec
19791 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) not in
19792 N_Generic_Package_Declaration |
19793 N_Generic_Subprogram_Declaration |
19794 N_Package_Declaration |
19795 N_Subprogram_Declaration
19799 ("pragma% can only occur for package "
19800 & "or subprogram spec"));
19803 -- Set flag in unit table
19805 Set_No_Elab_Code_All
(Current_Sem_Unit
);
19807 -- Set restriction No_Elaboration_Code if this is the main unit
19809 if Current_Sem_Unit
= Main_Unit
then
19810 Set_Restriction
(No_Elaboration_Code
, N
);
19813 -- If we are in the main unit or in an extended main source unit,
19814 -- then we also add it to the configuration restrictions so that
19815 -- it will apply to all units in the extended main source.
19817 if Current_Sem_Unit
= Main_Unit
19818 or else In_Extended_Main_Source_Unit
(N
)
19820 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
19823 -- If in main extended unit, activate transitive with test
19825 if In_Extended_Main_Source_Unit
(N
) then
19826 Opt
.No_Elab_Code_All_Pragma
:= N
;
19829 -----------------------------
19830 -- No_Component_Reordering --
19831 -----------------------------
19833 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19835 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
19841 Check_At_Most_N_Arguments
(1);
19843 if Arg_Count
= 0 then
19844 Check_Valid_Configuration_Pragma
;
19845 Opt
.No_Component_Reordering
:= True;
19848 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19849 Check_Arg_Is_Local_Name
(Arg1
);
19850 E_Id
:= Get_Pragma_Arg
(Arg1
);
19852 if Etype
(E_Id
) = Any_Type
then
19856 E
:= Entity
(E_Id
);
19858 if not Is_Record_Type
(E
) then
19859 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
19862 Set_No_Reordering
(Base_Type
(E
));
19864 end No_Comp_Reordering
;
19866 --------------------------
19867 -- No_Heap_Finalization --
19868 --------------------------
19870 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19872 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
19873 Context
: constant Node_Id
:= Parent
(N
);
19874 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19880 Check_No_Identifiers
;
19882 -- The pragma appears in a configuration file
19884 if No
(Context
) then
19885 Check_Arg_Count
(0);
19886 Check_Valid_Configuration_Pragma
;
19888 -- Detect a duplicate pragma
19890 if Present
(No_Heap_Finalization_Pragma
) then
19893 Prev
=> No_Heap_Finalization_Pragma
);
19897 No_Heap_Finalization_Pragma
:= N
;
19899 -- Otherwise the pragma should be associated with a library-level
19900 -- named access-to-object type.
19903 Check_Arg_Count
(1);
19904 Check_Arg_Is_Local_Name
(Arg1
);
19906 Find_Type
(Typ_Arg
);
19907 Typ
:= Entity
(Typ_Arg
);
19909 -- The type being subjected to the pragma is erroneous
19911 if Typ
= Any_Type
then
19912 Error_Pragma
("cannot find type referenced by pragma %");
19914 -- The pragma is applied to an incomplete or generic formal
19915 -- type way too early.
19917 elsif Rep_Item_Too_Early
(Typ
, N
) then
19921 Typ
:= Underlying_Type
(Typ
);
19924 -- The pragma must apply to an access-to-object type
19926 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
then
19929 -- Give a detailed error message on all other access type kinds
19931 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19933 ("pragma % cannot apply to access protected subprogram "
19936 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19938 ("pragma % cannot apply to access subprogram type");
19940 elsif Is_Anonymous_Access_Type
(Typ
) then
19942 ("pragma % cannot apply to anonymous access type");
19944 -- Give a general error message in case the pragma applies to a
19945 -- non-access type.
19949 ("pragma % must apply to library level access type");
19952 -- At this point the argument denotes an access-to-object type.
19953 -- Ensure that the type is declared at the library level.
19955 if Is_Library_Level_Entity
(Typ
) then
19958 -- Quietly ignore an access-to-object type originally declared
19959 -- at the library level within a generic, but instantiated at
19960 -- a non-library level. As a result the access-to-object type
19961 -- "loses" its No_Heap_Finalization property.
19963 elsif In_Instance
then
19968 ("pragma % must apply to library level access type");
19971 -- Detect a duplicate pragma
19973 if Present
(No_Heap_Finalization_Pragma
) then
19976 Prev
=> No_Heap_Finalization_Pragma
);
19980 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19982 if Present
(Prev
) then
19990 Record_Rep_Item
(Typ
, N
);
19992 end No_Heap_Finalization
;
19998 -- pragma No_Inline ( NAME {, NAME} );
20000 when Pragma_No_Inline
=>
20002 Process_Inline
(Suppressed
);
20008 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20010 when Pragma_No_Return
=> Prag_No_Return
: declare
20012 function Check_No_Return
20014 N
: Node_Id
) return Boolean;
20015 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
20016 -- emit an error message and return False, otherwise return True.
20017 -- 6.5.1 Nonreturning procedures:
20018 -- 4/3 "Aspect No_Return shall not be specified for a null
20019 -- procedure nor an instance of a generic unit."
20021 ---------------------
20022 -- Check_No_Return --
20023 ---------------------
20025 function Check_No_Return
20027 N
: Node_Id
) return Boolean
20030 if Ekind
(E
) = E_Procedure
then
20032 -- If E is a generic instance, marking it with No_Return
20033 -- is forbidden, but having it inherit the No_Return of
20034 -- the generic is allowed. We check if E is inheriting its
20035 -- No_Return flag from the generic by checking if No_Return
20038 if Is_Generic_Instance
(E
) and then not No_Return
(E
) then
20040 ("generic instance & is marked as No_Return", N
, E
);
20042 ("\generic procedure & must be marked No_Return",
20044 Generic_Parent
(Parent
(E
)));
20047 elsif Null_Present
(Subprogram_Specification
(E
)) then
20049 ("null procedure & cannot be marked No_Return", N
, E
);
20055 end Check_No_Return
;
20062 Ghost_Error_Posted
: Boolean := False;
20063 -- Flag set when an error concerning the illegal mix of Ghost and
20064 -- non-Ghost subprograms is emitted.
20066 Ghost_Id
: Entity_Id
:= Empty
;
20067 -- The entity of the first Ghost procedure encountered while
20068 -- processing the arguments of the pragma.
20072 Check_At_Least_N_Arguments
(1);
20074 -- Loop through arguments of pragma
20077 while Present
(Arg
) loop
20078 Check_Arg_Is_Local_Name
(Arg
);
20079 Id
:= Get_Pragma_Arg
(Arg
);
20082 if not Is_Entity_Name
(Id
) then
20083 Error_Pragma_Arg
("entity name required", Arg
);
20086 if Etype
(Id
) = Any_Type
then
20090 -- Loop to find matching procedures or functions (Ada 2022)
20096 and then Scope
(E
) = Current_Scope
20098 -- Ada 2022 (AI12-0269): A function can be No_Return
20100 if Ekind
(E
) in E_Generic_Procedure | E_Procedure
20101 or else (Ada_Version
>= Ada_2022
20103 Ekind
(E
) in E_Generic_Function | E_Function
)
20105 -- Check that the pragma is not applied to a body.
20106 -- First check the specless body case, to give a
20107 -- different error message. These checks do not apply
20108 -- if Relaxed_RM_Semantics, to accommodate other Ada
20109 -- compilers. Disable these checks under -gnatd.J.
20111 if not Debug_Flag_Dot_JJ
then
20112 if Nkind
(Parent
(Declaration_Node
(E
))) =
20114 and then not Relaxed_RM_Semantics
20117 ("pragma% requires separate spec and must come "
20121 -- Now the "specful" body case
20123 if Rep_Item_Too_Late
(E
, N
) then
20128 if Check_No_Return
(E
, N
) then
20132 -- A pragma that applies to a Ghost entity becomes Ghost
20133 -- for the purposes of legality checks and removal of
20134 -- ignored Ghost code.
20136 Mark_Ghost_Pragma
(N
, E
);
20138 -- Capture the entity of the first Ghost procedure being
20139 -- processed for error detection purposes.
20141 if Is_Ghost_Entity
(E
) then
20142 if No
(Ghost_Id
) then
20146 -- Otherwise the subprogram is non-Ghost. It is illegal
20147 -- to mix references to Ghost and non-Ghost entities
20150 elsif Present
(Ghost_Id
)
20151 and then not Ghost_Error_Posted
20153 Ghost_Error_Posted
:= True;
20155 Error_Msg_Name_1
:= Pname
;
20157 ("pragma % cannot mention ghost and non-ghost "
20158 & "procedures", N
);
20160 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
20161 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
20163 Error_Msg_Sloc
:= Sloc
(E
);
20164 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
20167 -- Set flag on any alias as well
20169 if Is_Overloadable
(E
)
20170 and then Present
(Alias
(E
))
20171 and then Check_No_Return
(Alias
(E
), N
)
20173 Set_No_Return
(Alias
(E
));
20179 exit when From_Aspect_Specification
(N
);
20183 -- If entity in not in current scope it may be the enclosing
20184 -- subprogram body to which the aspect applies.
20187 if Entity
(Id
) = Current_Scope
20188 and then From_Aspect_Specification
(N
)
20189 and then Check_No_Return
(Entity
(Id
), N
)
20191 Set_No_Return
(Entity
(Id
));
20193 elsif Ada_Version
>= Ada_2022
then
20195 ("no subprogram& found for pragma%", Arg
);
20198 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
20204 end Prag_No_Return
;
20210 -- pragma No_Run_Time;
20212 -- Note: this pragma is retained for backwards compatibility. See
20213 -- body of Rtsfind for full details on its handling.
20215 when Pragma_No_Run_Time
=>
20217 Check_Valid_Configuration_Pragma
;
20218 Check_Arg_Count
(0);
20220 -- Remove backward compatibility if Build_Type is FSF or GPL and
20221 -- generate a warning.
20224 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
20227 Error_Pragma
("pragma% is ignored, has no effect??");
20229 No_Run_Time_Mode
:= True;
20230 Configurable_Run_Time_Mode
:= True;
20232 -- Set Duration to 32 bits if word size is 32
20234 if Ttypes
.System_Word_Size
= 32 then
20235 Duration_32_Bits_On_Target
:= True;
20238 -- Set appropriate restrictions
20240 Set_Restriction
(No_Finalization
, N
);
20241 Set_Restriction
(No_Exception_Handlers
, N
);
20242 Set_Restriction
(Max_Tasks
, N
, 0);
20243 Set_Restriction
(No_Tasking
, N
);
20247 -----------------------
20248 -- No_Tagged_Streams --
20249 -----------------------
20251 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20253 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20259 Check_At_Most_N_Arguments
(1);
20261 -- One argument case
20263 if Arg_Count
= 1 then
20264 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20265 Check_Arg_Is_Local_Name
(Arg1
);
20266 E_Id
:= Get_Pragma_Arg
(Arg1
);
20268 if Etype
(E_Id
) = Any_Type
then
20272 E
:= Entity
(E_Id
);
20274 Check_Duplicate_Pragma
(E
);
20276 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20278 ("argument for pragma% must be root tagged type", Arg1
);
20281 if Rep_Item_Too_Early
(E
, N
)
20283 Rep_Item_Too_Late
(E
, N
)
20287 Set_No_Tagged_Streams_Pragma
(E
, N
);
20290 -- Zero argument case
20293 Check_Is_In_Decl_Part_Or_Package_Spec
;
20294 No_Tagged_Streams
:= N
;
20296 end No_Tagged_Strms
;
20298 ------------------------
20299 -- No_Strict_Aliasing --
20300 ------------------------
20302 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20304 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20310 Check_At_Most_N_Arguments
(1);
20312 if Arg_Count
= 0 then
20313 Check_Valid_Configuration_Pragma
;
20314 Opt
.No_Strict_Aliasing
:= True;
20317 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20318 Check_Arg_Is_Local_Name
(Arg1
);
20319 E_Id
:= Get_Pragma_Arg
(Arg1
);
20321 if Etype
(E_Id
) = Any_Type
then
20325 E
:= Entity
(E_Id
);
20327 if not Is_Access_Type
(E
) then
20328 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
20331 Set_No_Strict_Aliasing
(Base_Type
(E
));
20333 end No_Strict_Aliasing
;
20335 -----------------------
20336 -- Normalize_Scalars --
20337 -----------------------
20339 -- pragma Normalize_Scalars;
20341 when Pragma_Normalize_Scalars
=>
20342 Check_Ada_83_Warning
;
20343 Check_Arg_Count
(0);
20344 Check_Valid_Configuration_Pragma
;
20346 -- Normalize_Scalars creates false positives in CodePeer, and
20347 -- incorrect negative results in GNATprove mode, so ignore this
20348 -- pragma in these modes.
20350 if not (CodePeer_Mode
or GNATprove_Mode
) then
20351 Normalize_Scalars
:= True;
20352 Init_Or_Norm_Scalars
:= True;
20359 -- pragma Obsolescent;
20361 -- pragma Obsolescent (
20362 -- [Message =>] static_string_EXPRESSION
20363 -- [,[Version =>] Ada_05]);
20365 -- pragma Obsolescent (
20366 -- [Entity =>] NAME
20367 -- [,[Message =>] static_string_EXPRESSION
20368 -- [,[Version =>] Ada_05]]);
20370 when Pragma_Obsolescent
=> Obsolescent
: declare
20374 procedure Set_Obsolescent
(E
: Entity_Id
);
20375 -- Given an entity Ent, mark it as obsolescent if appropriate
20377 ---------------------
20378 -- Set_Obsolescent --
20379 ---------------------
20381 procedure Set_Obsolescent
(E
: Entity_Id
) is
20390 -- A pragma that applies to a Ghost entity becomes Ghost for
20391 -- the purposes of legality checks and removal of ignored Ghost
20394 Mark_Ghost_Pragma
(N
, E
);
20396 -- Entity name was given
20398 if Present
(Ename
) then
20400 -- If entity name matches, we are fine.
20402 if Chars
(Ename
) = Chars
(Ent
) then
20403 Set_Entity
(Ename
, Ent
);
20404 Generate_Reference
(Ent
, Ename
);
20406 -- If entity name does not match, only possibility is an
20407 -- enumeration literal from an enumeration type declaration.
20409 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
20411 ("pragma % entity name does not match declaration");
20414 Ent
:= First_Literal
(E
);
20418 ("pragma % entity name does not match any "
20419 & "enumeration literal");
20421 elsif Chars
(Ent
) = Chars
(Ename
) then
20422 Set_Entity
(Ename
, Ent
);
20423 Generate_Reference
(Ent
, Ename
);
20427 Next_Literal
(Ent
);
20433 -- Ent points to entity to be marked
20435 if Arg_Count
>= 1 then
20437 -- Deal with static string argument
20439 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20440 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
20442 for J
in 1 .. String_Length
(S
) loop
20443 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
20445 ("pragma% argument does not allow wide characters",
20450 Obsolescent_Warnings
.Append
20451 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
20453 -- Check for Ada_05 parameter
20455 if Arg_Count
/= 1 then
20456 Check_Arg_Count
(2);
20459 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20462 Check_Arg_Is_Identifier
(Argx
);
20464 if Chars
(Argx
) /= Name_Ada_05
then
20465 Error_Msg_Name_2
:= Name_Ada_05
;
20467 ("only allowed argument for pragma% is %", Argx
);
20470 if Ada_Version_Explicit
< Ada_2005
20471 or else not Warn_On_Ada_2005_Compatibility
20479 -- Set flag if pragma active
20482 Set_Is_Obsolescent
(Ent
);
20486 end Set_Obsolescent
;
20488 -- Start of processing for pragma Obsolescent
20493 Check_At_Most_N_Arguments
(3);
20495 -- See if first argument specifies an entity name
20499 (Chars
(Arg1
) = Name_Entity
20501 Nkind
(Get_Pragma_Arg
(Arg1
)) in
20502 N_Character_Literal | N_Identifier | N_Operator_Symbol
)
20504 Ename
:= Get_Pragma_Arg
(Arg1
);
20506 -- Eliminate first argument, so we can share processing
20510 Arg_Count
:= Arg_Count
- 1;
20512 -- No Entity name argument given
20518 if Arg_Count
>= 1 then
20519 Check_Optional_Identifier
(Arg1
, Name_Message
);
20521 if Arg_Count
= 2 then
20522 Check_Optional_Identifier
(Arg2
, Name_Version
);
20526 -- Get immediately preceding declaration
20529 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
20533 -- Cases where we do not follow anything other than another pragma
20537 -- Case 0: library level compilation unit declaration with
20538 -- the pragma preceding the declaration.
20540 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
20543 -- Case 1: library level compilation unit declaration with
20544 -- the pragma immediately following the declaration.
20546 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
20548 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
20551 -- Case 2: library unit placement for package
20555 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
20557 if Is_Package_Or_Generic_Package
(Ent
) then
20558 Set_Obsolescent
(Ent
);
20564 -- Cases where we must follow a declaration, including an
20565 -- abstract subprogram declaration, which is not in the
20566 -- other node subtypes.
20569 if Nkind
(Decl
) not in N_Declaration
20570 and then Nkind
(Decl
) not in N_Later_Decl_Item
20571 and then Nkind
(Decl
) not in N_Generic_Declaration
20572 and then Nkind
(Decl
) not in N_Renaming_Declaration
20573 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
20576 ("pragma% misplaced, "
20577 & "must immediately follow a declaration");
20580 Set_Obsolescent
(Defining_Entity
(Decl
));
20590 -- pragma Optimize (Time | Space | Off);
20592 -- The actual check for optimize is done in Gigi. Note that this
20593 -- pragma does not actually change the optimization setting, it
20594 -- simply checks that it is consistent with the pragma.
20596 when Pragma_Optimize
=>
20597 Check_No_Identifiers
;
20598 Check_Arg_Count
(1);
20599 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
20601 ------------------------
20602 -- Optimize_Alignment --
20603 ------------------------
20605 -- pragma Optimize_Alignment (Time | Space | Off);
20607 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
20609 Check_No_Identifiers
;
20610 Check_Arg_Count
(1);
20611 Check_Valid_Configuration_Pragma
;
20614 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
20617 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
20618 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
20619 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
20622 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
20626 -- Set indication that mode is set locally. If we are in fact in a
20627 -- configuration pragma file, this setting is harmless since the
20628 -- switch will get reset anyway at the start of each unit.
20630 Optimize_Alignment_Local
:= True;
20631 end Optimize_Alignment
;
20637 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20639 when Pragma_Ordered
=> Ordered
: declare
20640 Assoc
: constant Node_Id
:= Arg1
;
20646 Check_No_Identifiers
;
20647 Check_Arg_Count
(1);
20648 Check_Arg_Is_Local_Name
(Arg1
);
20650 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20651 Find_Type
(Type_Id
);
20652 Typ
:= Entity
(Type_Id
);
20654 if Typ
= Any_Type
then
20657 Typ
:= Underlying_Type
(Typ
);
20660 if not Is_Enumeration_Type
(Typ
) then
20661 Error_Pragma
("pragma% must specify enumeration type");
20664 Check_First_Subtype
(Arg1
);
20665 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
20668 -------------------
20669 -- Overflow_Mode --
20670 -------------------
20672 -- pragma Overflow_Mode
20673 -- ([General => ] MODE [, [Assertions => ] MODE]);
20675 -- MODE := STRICT | MINIMIZED | ELIMINATED
20677 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20678 -- since System.Bignums makes this assumption. This is true of nearly
20679 -- all (all?) targets.
20681 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
20682 function Get_Overflow_Mode
20684 Arg
: Node_Id
) return Overflow_Mode_Type
;
20685 -- Function to process one pragma argument, Arg. If an identifier
20686 -- is present, it must be Name. Mode type is returned if a valid
20687 -- argument exists, otherwise an error is signalled.
20689 -----------------------
20690 -- Get_Overflow_Mode --
20691 -----------------------
20693 function Get_Overflow_Mode
20695 Arg
: Node_Id
) return Overflow_Mode_Type
20697 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
20700 Check_Optional_Identifier
(Arg
, Name
);
20701 Check_Arg_Is_Identifier
(Argx
);
20703 if Chars
(Argx
) = Name_Strict
then
20706 elsif Chars
(Argx
) = Name_Minimized
then
20709 elsif Chars
(Argx
) = Name_Eliminated
then
20710 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
20712 ("Eliminated requires Long_Long_Integer'Size = 64",
20719 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
20721 end Get_Overflow_Mode
;
20723 -- Start of processing for Overflow_Mode
20727 Check_At_Least_N_Arguments
(1);
20728 Check_At_Most_N_Arguments
(2);
20730 -- Process first argument
20732 Scope_Suppress
.Overflow_Mode_General
:=
20733 Get_Overflow_Mode
(Name_General
, Arg1
);
20735 -- Case of only one argument
20737 if Arg_Count
= 1 then
20738 Scope_Suppress
.Overflow_Mode_Assertions
:=
20739 Scope_Suppress
.Overflow_Mode_General
;
20741 -- Case of two arguments present
20744 Scope_Suppress
.Overflow_Mode_Assertions
:=
20745 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
20749 --------------------------
20750 -- Overriding Renamings --
20751 --------------------------
20753 -- pragma Overriding_Renamings;
20755 when Pragma_Overriding_Renamings
=>
20757 Check_Arg_Count
(0);
20758 Check_Valid_Configuration_Pragma
;
20759 Overriding_Renamings
:= True;
20765 -- pragma Pack (first_subtype_LOCAL_NAME);
20767 when Pragma_Pack
=> Pack
: declare
20768 Assoc
: constant Node_Id
:= Arg1
;
20770 Ignore
: Boolean := False;
20775 Check_No_Identifiers
;
20776 Check_Arg_Count
(1);
20777 Check_Arg_Is_Local_Name
(Arg1
);
20778 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20780 if not Is_Entity_Name
(Type_Id
)
20781 or else not Is_Type
(Entity
(Type_Id
))
20784 ("argument for pragma% must be type or subtype", Arg1
);
20787 Find_Type
(Type_Id
);
20788 Typ
:= Entity
(Type_Id
);
20791 or else Rep_Item_Too_Early
(Typ
, N
)
20795 Typ
:= Underlying_Type
(Typ
);
20798 -- A pragma that applies to a Ghost entity becomes Ghost for the
20799 -- purposes of legality checks and removal of ignored Ghost code.
20801 Mark_Ghost_Pragma
(N
, Typ
);
20803 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
20804 Error_Pragma
("pragma% must specify array or record type");
20807 Check_First_Subtype
(Arg1
);
20808 Check_Duplicate_Pragma
(Typ
);
20812 if Is_Array_Type
(Typ
) then
20813 Ctyp
:= Component_Type
(Typ
);
20815 -- Ignore pack that does nothing
20817 if Known_Static_Esize
(Ctyp
)
20818 and then Known_Static_RM_Size
(Ctyp
)
20819 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
20820 and then Addressable
(Esize
(Ctyp
))
20825 -- Process OK pragma Pack. Note that if there is a separate
20826 -- component clause present, the Pack will be cancelled. This
20827 -- processing is in Freeze.
20829 if not Rep_Item_Too_Late
(Typ
, N
) then
20831 -- In CodePeer mode, we do not need complex front-end
20832 -- expansions related to pragma Pack, so disable handling
20835 if CodePeer_Mode
then
20838 -- Normal case where we do the pack action
20842 Set_Is_Packed
(Base_Type
(Typ
));
20843 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20846 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20850 -- For record types, the pack is always effective
20852 else pragma Assert
(Is_Record_Type
(Typ
));
20853 if not Rep_Item_Too_Late
(Typ
, N
) then
20854 Set_Is_Packed
(Base_Type
(Typ
));
20855 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20856 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20867 -- There is nothing to do here, since we did all the processing for
20868 -- this pragma in Par.Prag (so that it works properly even in syntax
20871 when Pragma_Page
=>
20878 -- pragma Part_Of (ABSTRACT_STATE);
20880 -- ABSTRACT_STATE ::= NAME
20882 when Pragma_Part_Of
=> Part_Of
: declare
20883 procedure Propagate_Part_Of
20884 (Pack_Id
: Entity_Id
;
20885 State_Id
: Entity_Id
;
20886 Instance
: Node_Id
);
20887 -- Propagate the Part_Of indicator to all abstract states and
20888 -- objects declared in the visible state space of a package
20889 -- denoted by Pack_Id. State_Id is the encapsulating state.
20890 -- Instance is the package instantiation node.
20892 -----------------------
20893 -- Propagate_Part_Of --
20894 -----------------------
20896 procedure Propagate_Part_Of
20897 (Pack_Id
: Entity_Id
;
20898 State_Id
: Entity_Id
;
20899 Instance
: Node_Id
)
20901 Has_Item
: Boolean := False;
20902 -- Flag set when the visible state space contains at least one
20903 -- abstract state or variable.
20905 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
20906 -- Propagate the Part_Of indicator to all abstract states and
20907 -- objects declared in the visible state space of a package
20908 -- denoted by Pack_Id.
20910 -----------------------
20911 -- Propagate_Part_Of --
20912 -----------------------
20914 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
20915 Constits
: Elist_Id
;
20916 Item_Id
: Entity_Id
;
20919 -- Traverse the entity chain of the package and set relevant
20920 -- attributes of abstract states and objects declared in the
20921 -- visible state space of the package.
20923 Item_Id
:= First_Entity
(Pack_Id
);
20924 while Present
(Item_Id
)
20925 and then not In_Private_Part
(Item_Id
)
20927 -- Do not consider internally generated items
20929 if not Comes_From_Source
(Item_Id
) then
20932 -- Do not consider generic formals or their corresponding
20933 -- actuals because they are not part of a visible state.
20934 -- Note that both entities are marked as hidden.
20936 elsif Is_Hidden
(Item_Id
) then
20939 -- The Part_Of indicator turns an abstract state or an
20940 -- object into a constituent of the encapsulating state.
20941 -- Note that constants are considered here even though
20942 -- they may not depend on variable input. This check is
20943 -- left to the SPARK prover.
20945 elsif Ekind
(Item_Id
) in
20946 E_Abstract_State | E_Constant | E_Variable
20949 Constits
:= Part_Of_Constituents
(State_Id
);
20951 if No
(Constits
) then
20952 Constits
:= New_Elmt_List
;
20953 Set_Part_Of_Constituents
(State_Id
, Constits
);
20956 Append_Elmt
(Item_Id
, Constits
);
20957 Set_Encapsulating_State
(Item_Id
, State_Id
);
20959 -- Recursively handle nested packages and instantiations
20961 elsif Ekind
(Item_Id
) = E_Package
then
20962 Propagate_Part_Of
(Item_Id
);
20965 Next_Entity
(Item_Id
);
20967 end Propagate_Part_Of
;
20969 -- Start of processing for Propagate_Part_Of
20972 Propagate_Part_Of
(Pack_Id
);
20974 -- Detect a package instantiation that is subject to a Part_Of
20975 -- indicator, but has no visible state.
20977 if not Has_Item
then
20979 ("package instantiation & has Part_Of indicator but "
20980 & "lacks visible state", Instance
, Pack_Id
);
20982 end Propagate_Part_Of
;
20986 Constits
: Elist_Id
;
20988 Encap_Id
: Entity_Id
;
20989 Item_Id
: Entity_Id
;
20993 -- Start of processing for Part_Of
20997 Check_No_Identifiers
;
20998 Check_Arg_Count
(1);
21000 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
21002 -- Object declaration
21004 if Nkind
(Stmt
) = N_Object_Declaration
then
21007 -- Package instantiation
21009 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
21012 -- Single concurrent type declaration
21014 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
21017 -- Otherwise the pragma is associated with an illegal construct
21023 -- Extract the entity of the related object declaration or package
21024 -- instantiation. In the case of the instantiation, use the entity
21025 -- of the instance spec.
21027 if Nkind
(Stmt
) = N_Package_Instantiation
then
21028 Stmt
:= Instance_Spec
(Stmt
);
21031 Item_Id
:= Defining_Entity
(Stmt
);
21033 -- A pragma that applies to a Ghost entity becomes Ghost for the
21034 -- purposes of legality checks and removal of ignored Ghost code.
21036 Mark_Ghost_Pragma
(N
, Item_Id
);
21038 -- Chain the pragma on the contract for further processing by
21039 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21041 Add_Contract_Item
(N
, Item_Id
);
21043 -- A variable may act as constituent of a single concurrent type
21044 -- which in turn could be declared after the variable. Due to this
21045 -- discrepancy, the full analysis of indicator Part_Of is delayed
21046 -- until the end of the enclosing declarative region (see routine
21047 -- Analyze_Part_Of_In_Decl_Part).
21049 if Ekind
(Item_Id
) = E_Variable
then
21052 -- Otherwise indicator Part_Of applies to a constant or a package
21056 Encap
:= Get_Pragma_Arg
(Arg1
);
21058 -- Detect any discrepancies between the placement of the
21059 -- constant or package instantiation with respect to state
21060 -- space and the encapsulating state.
21064 Item_Id
=> Item_Id
,
21066 Encap_Id
=> Encap_Id
,
21070 pragma Assert
(Present
(Encap_Id
));
21072 if Ekind
(Item_Id
) = E_Constant
then
21073 Constits
:= Part_Of_Constituents
(Encap_Id
);
21075 if No
(Constits
) then
21076 Constits
:= New_Elmt_List
;
21077 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
21080 Append_Elmt
(Item_Id
, Constits
);
21081 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
21083 -- Propagate the Part_Of indicator to the visible state
21084 -- space of the package instantiation.
21088 (Pack_Id
=> Item_Id
,
21089 State_Id
=> Encap_Id
,
21096 ----------------------------------
21097 -- Partition_Elaboration_Policy --
21098 ----------------------------------
21100 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21102 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
21103 subtype PEP_Range
is Name_Id
21104 range First_Partition_Elaboration_Policy_Name
21105 .. Last_Partition_Elaboration_Policy_Name
;
21106 PEP_Val
: PEP_Range
;
21111 Check_Arg_Count
(1);
21112 Check_No_Identifiers
;
21113 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
21114 Check_Valid_Configuration_Pragma
;
21115 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
21118 when Name_Concurrent
=> PEP
:= 'C';
21119 when Name_Sequential
=> PEP
:= 'S';
21122 if Partition_Elaboration_Policy
/= ' '
21123 and then Partition_Elaboration_Policy
/= PEP
21125 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
21127 ("partition elaboration policy incompatible with policy#");
21129 -- Set new policy, but always preserve System_Location since we
21130 -- like the error message with the run time name.
21133 Partition_Elaboration_Policy
:= PEP
;
21135 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
21136 Partition_Elaboration_Policy_Sloc
:= Loc
;
21139 if PEP_Val
= Name_Sequential
21140 and then not Restriction_Active
(No_Task_Hierarchy
)
21142 -- RM H.6(6) guarantees that No_Task_Hierarchy will be
21143 -- set eventually, so take advantage of that knowledge now.
21144 -- But we have to do this in a tricky way. If we simply
21145 -- set the No_Task_Hierarchy restriction here, then the
21146 -- assumption that the restriction will be set eventually
21147 -- becomes a self-fulfilling prophecy; the binder can
21148 -- then mistakenly conclude that the H.6(6) rule is
21149 -- satisified in cases where the post-compilation check
21150 -- should fail. So we invent a new restriction,
21151 -- No_Task_Hierarchy_Implicit, which is treated specially
21152 -- in the function Restriction_Active.
21154 Set_Restriction
(No_Task_Hierarchy_Implicit
, N
);
21155 pragma Assert
(Restriction_Active
(No_Task_Hierarchy
));
21164 -- pragma Passive [(PASSIVE_FORM)];
21166 -- PASSIVE_FORM ::= Semaphore | No
21168 when Pragma_Passive
=>
21171 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
21172 Error_Pragma
("pragma% must be within task definition");
21175 if Arg_Count
/= 0 then
21176 Check_Arg_Count
(1);
21177 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
21180 ----------------------------------
21181 -- Preelaborable_Initialization --
21182 ----------------------------------
21184 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21186 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
21191 Check_Arg_Count
(1);
21192 Check_No_Identifiers
;
21193 Check_Arg_Is_Identifier
(Arg1
);
21194 Check_Arg_Is_Local_Name
(Arg1
);
21195 Check_First_Subtype
(Arg1
);
21196 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21198 -- A pragma that applies to a Ghost entity becomes Ghost for the
21199 -- purposes of legality checks and removal of ignored Ghost code.
21201 Mark_Ghost_Pragma
(N
, Ent
);
21203 -- The pragma may come from an aspect on a private declaration,
21204 -- even if the freeze point at which this is analyzed in the
21205 -- private part after the full view.
21207 if Has_Private_Declaration
(Ent
)
21208 and then From_Aspect_Specification
(N
)
21212 -- Check appropriate type argument
21214 elsif Is_Private_Type
(Ent
)
21215 or else Is_Protected_Type
(Ent
)
21216 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
21218 -- AI05-0028: The pragma applies to all composite types. Note
21219 -- that we apply this binding interpretation to earlier versions
21220 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21221 -- choice since there are other compilers that do the same.
21223 or else Is_Composite_Type
(Ent
)
21229 ("pragma % can only be applied to private, formal derived, "
21230 & "protected, or composite type", Arg1
);
21233 -- Give an error if the pragma is applied to a protected type that
21234 -- does not qualify (due to having entries, or due to components
21235 -- that do not qualify).
21237 if Is_Protected_Type
(Ent
)
21238 and then not Has_Preelaborable_Initialization
(Ent
)
21241 ("protected type & does not have preelaborable "
21242 & "initialization", Ent
);
21244 -- Otherwise mark the type as definitely having preelaborable
21248 Set_Known_To_Have_Preelab_Init
(Ent
);
21251 if Has_Pragma_Preelab_Init
(Ent
)
21252 and then Warn_On_Redundant_Constructs
21254 Error_Pragma
("?r?duplicate pragma%!");
21256 Set_Has_Pragma_Preelab_Init
(Ent
);
21260 --------------------
21261 -- Persistent_BSS --
21262 --------------------
21264 -- pragma Persistent_BSS [(object_NAME)];
21266 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21273 Check_At_Most_N_Arguments
(1);
21275 -- Case of application to specific object (one argument)
21277 if Arg_Count
= 1 then
21278 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21280 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21282 Ekind
(Entity
(Get_Pragma_Arg
(Arg1
))) not in
21283 E_Variable | E_Constant
21285 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21288 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21290 -- A pragma that applies to a Ghost entity becomes Ghost for
21291 -- the purposes of legality checks and removal of ignored Ghost
21294 Mark_Ghost_Pragma
(N
, Ent
);
21296 -- Check for duplication before inserting in list of
21297 -- representation items.
21299 Check_Duplicate_Pragma
(Ent
);
21301 if Rep_Item_Too_Late
(Ent
, N
) then
21305 Decl
:= Parent
(Ent
);
21307 if Present
(Expression
(Decl
)) then
21308 -- Variables in Persistent_BSS cannot be initialized, so
21309 -- turn off any initialization that might be caused by
21310 -- pragmas Initialize_Scalars or Normalize_Scalars.
21312 if Kill_Range_Check
(Expression
(Decl
)) then
21315 Name_Suppress_Initialization
,
21316 Pragma_Argument_Associations
=> New_List
(
21317 Make_Pragma_Argument_Association
(Loc
,
21318 Expression
=> New_Occurrence_Of
(Ent
, Loc
))));
21319 Insert_Before
(N
, Prag
);
21324 ("object for pragma% cannot have initialization", Arg1
);
21328 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
21330 ("object type for pragma% is not potentially persistent",
21335 Make_Linker_Section_Pragma
21336 (Ent
, Loc
, ".persistent.bss");
21337 Insert_After
(N
, Prag
);
21340 -- Case of use as configuration pragma with no arguments
21343 Check_Valid_Configuration_Pragma
;
21344 Persistent_BSS_Mode
:= True;
21346 end Persistent_BSS
;
21348 --------------------
21349 -- Rename_Pragma --
21350 --------------------
21352 -- pragma Rename_Pragma (
21353 -- [New_Name =>] IDENTIFIER,
21354 -- [Renamed =>] pragma_IDENTIFIER);
21356 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
21357 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21358 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21362 Check_Valid_Configuration_Pragma
;
21363 Check_Arg_Count
(2);
21364 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
21365 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
21367 if Nkind
(New_Name
) /= N_Identifier
then
21368 Error_Pragma_Arg
("identifier expected", Arg1
);
21371 if Nkind
(Old_Name
) /= N_Identifier
then
21372 Error_Pragma_Arg
("identifier expected", Arg2
);
21375 -- The New_Name arg should not be an existing pragma (but we allow
21376 -- it; it's just a warning). The Old_Name arg must be an existing
21379 if Is_Pragma_Name
(Chars
(New_Name
)) then
21380 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
21383 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
21384 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
21387 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
21390 -----------------------------------
21391 -- Post/Post_Class/Postcondition --
21392 -----------------------------------
21394 -- pragma Post (Boolean_EXPRESSION);
21395 -- pragma Post_Class (Boolean_EXPRESSION);
21396 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21397 -- [,[Message =>] String_EXPRESSION]);
21399 -- Characteristics:
21401 -- * Analysis - The annotation undergoes initial checks to verify
21402 -- the legal placement and context. Secondary checks preanalyze the
21405 -- Analyze_Pre_Post_Condition_In_Decl_Part
21407 -- * Expansion - The annotation is expanded during the expansion of
21408 -- the related subprogram [body] contract as performed in:
21410 -- Expand_Subprogram_Contract
21412 -- * Template - The annotation utilizes the generic template of the
21413 -- related subprogram [body] when it is:
21415 -- aspect on subprogram declaration
21416 -- aspect on stand-alone subprogram body
21417 -- pragma on stand-alone subprogram body
21419 -- The annotation must prepare its own template when it is:
21421 -- pragma on subprogram declaration
21423 -- * Globals - Capture of global references must occur after full
21426 -- * Instance - The annotation is instantiated automatically when
21427 -- the related generic subprogram [body] is instantiated except for
21428 -- the "pragma on subprogram declaration" case. In that scenario
21429 -- the annotation must instantiate itself.
21432 | Pragma_Post_Class
21433 | Pragma_Postcondition
21435 Analyze_Pre_Post_Condition
;
21437 --------------------------------
21438 -- Pre/Pre_Class/Precondition --
21439 --------------------------------
21441 -- pragma Pre (Boolean_EXPRESSION);
21442 -- pragma Pre_Class (Boolean_EXPRESSION);
21443 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21444 -- [,[Message =>] String_EXPRESSION]);
21446 -- Characteristics:
21448 -- * Analysis - The annotation undergoes initial checks to verify
21449 -- the legal placement and context. Secondary checks preanalyze the
21452 -- Analyze_Pre_Post_Condition_In_Decl_Part
21454 -- * Expansion - The annotation is expanded during the expansion of
21455 -- the related subprogram [body] contract as performed in:
21457 -- Expand_Subprogram_Contract
21459 -- * Template - The annotation utilizes the generic template of the
21460 -- related subprogram [body] when it is:
21462 -- aspect on subprogram declaration
21463 -- aspect on stand-alone subprogram body
21464 -- pragma on stand-alone subprogram body
21466 -- The annotation must prepare its own template when it is:
21468 -- pragma on subprogram declaration
21470 -- * Globals - Capture of global references must occur after full
21473 -- * Instance - The annotation is instantiated automatically when
21474 -- the related generic subprogram [body] is instantiated except for
21475 -- the "pragma on subprogram declaration" case. In that scenario
21476 -- the annotation must instantiate itself.
21480 | Pragma_Precondition
21482 Analyze_Pre_Post_Condition
;
21488 -- pragma Predicate
21489 -- ([Entity =>] type_LOCAL_NAME,
21490 -- [Check =>] boolean_EXPRESSION);
21492 when Pragma_Predicate
=> Predicate
: declare
21499 Check_Arg_Count
(2);
21500 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21501 Check_Optional_Identifier
(Arg2
, Name_Check
);
21503 Check_Arg_Is_Local_Name
(Arg1
);
21505 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21506 Find_Type
(Type_Id
);
21507 Typ
:= Entity
(Type_Id
);
21509 if Typ
= Any_Type
then
21513 -- A pragma that applies to a Ghost entity becomes Ghost for the
21514 -- purposes of legality checks and removal of ignored Ghost code.
21516 Mark_Ghost_Pragma
(N
, Typ
);
21518 -- The remaining processing is simply to link the pragma on to
21519 -- the rep item chain, for processing when the type is frozen.
21520 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21521 -- mark the type as having predicates.
21523 -- If the current policy for predicate checking is Ignore mark the
21524 -- subtype accordingly. In the case of predicates we consider them
21525 -- enabled unless Ignore is specified (either directly or with a
21526 -- general Assertion_Policy pragma) to preserve existing warnings.
21528 Set_Has_Predicates
(Typ
);
21530 -- Indicate that the pragma must be processed at the point the
21531 -- type is frozen, as is done for the corresponding aspect.
21533 Set_Has_Delayed_Aspects
(Typ
);
21534 Set_Has_Delayed_Freeze
(Typ
);
21536 Set_Predicates_Ignored
(Typ
,
21537 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
21538 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21541 -----------------------
21542 -- Predicate_Failure --
21543 -----------------------
21545 -- pragma Predicate_Failure
21546 -- ([Entity =>] type_LOCAL_NAME,
21547 -- [Message =>] string_EXPRESSION);
21549 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
21556 Check_Arg_Count
(2);
21557 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21558 Check_Optional_Identifier
(Arg2
, Name_Message
);
21560 Check_Arg_Is_Local_Name
(Arg1
);
21562 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21563 Find_Type
(Type_Id
);
21564 Typ
:= Entity
(Type_Id
);
21566 if Typ
= Any_Type
then
21570 -- A pragma that applies to a Ghost entity becomes Ghost for the
21571 -- purposes of legality checks and removal of ignored Ghost code.
21573 Mark_Ghost_Pragma
(N
, Typ
);
21575 -- The remaining processing is simply to link the pragma on to
21576 -- the rep item chain, for processing when the type is frozen.
21577 -- This is accomplished by a call to Rep_Item_Too_Late.
21579 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21580 end Predicate_Failure
;
21586 -- pragma Preelaborate [(library_unit_NAME)];
21588 -- Set the flag Is_Preelaborated of program unit name entity
21590 when Pragma_Preelaborate
=> Preelaborate
: declare
21591 Pa
: constant Node_Id
:= Parent
(N
);
21592 Pk
: constant Node_Kind
:= Nkind
(Pa
);
21596 Check_Ada_83_Warning
;
21597 Check_Valid_Library_Unit_Pragma
;
21599 -- If N was rewritten as a null statement there is nothing more
21602 if Nkind
(N
) = N_Null_Statement
then
21606 Ent
:= Find_Lib_Unit_Name
;
21608 -- A pragma that applies to a Ghost entity becomes Ghost for the
21609 -- purposes of legality checks and removal of ignored Ghost code.
21611 Mark_Ghost_Pragma
(N
, Ent
);
21612 Check_Duplicate_Pragma
(Ent
);
21614 -- This filters out pragmas inside generic parents that show up
21615 -- inside instantiations. Pragmas that come from aspects in the
21616 -- unit are not ignored.
21618 if Present
(Ent
) then
21619 if Pk
= N_Package_Specification
21620 and then Present
(Generic_Parent
(Pa
))
21621 and then not From_Aspect_Specification
(N
)
21626 if not Debug_Flag_U
then
21627 Set_Is_Preelaborated
(Ent
);
21629 if Legacy_Elaboration_Checks
then
21630 Set_Suppress_Elaboration_Warnings
(Ent
);
21637 -------------------------------
21638 -- Prefix_Exception_Messages --
21639 -------------------------------
21641 -- pragma Prefix_Exception_Messages;
21643 when Pragma_Prefix_Exception_Messages
=>
21645 Check_Valid_Configuration_Pragma
;
21646 Check_Arg_Count
(0);
21647 Prefix_Exception_Messages
:= True;
21653 -- pragma Priority (EXPRESSION);
21655 when Pragma_Priority
=> Priority
: declare
21656 P
: constant Node_Id
:= Parent
(N
);
21661 Check_No_Identifiers
;
21662 Check_Arg_Count
(1);
21666 if Nkind
(P
) = N_Subprogram_Body
then
21667 Check_In_Main_Program
;
21669 Ent
:= Defining_Unit_Name
(Specification
(P
));
21671 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
21672 Ent
:= Defining_Identifier
(Ent
);
21675 Arg
:= Get_Pragma_Arg
(Arg1
);
21676 Analyze_And_Resolve
(Arg
, Standard_Integer
);
21680 if not Is_OK_Static_Expression
(Arg
) then
21681 Flag_Non_Static_Expr
21682 ("main subprogram priority is not static!", Arg
);
21685 -- If constraint error, then we already signalled an error
21687 elsif Raises_Constraint_Error
(Arg
) then
21690 -- Otherwise check in range except if Relaxed_RM_Semantics
21691 -- where we ignore the value if out of range.
21694 if not Relaxed_RM_Semantics
21695 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
21698 ("main subprogram priority is out of range", Arg1
);
21701 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
21705 -- Load an arbitrary entity from System.Tasking.Stages or
21706 -- System.Tasking.Restricted.Stages (depending on the
21707 -- supported profile) to make sure that one of these packages
21708 -- is implicitly with'ed, since we need to have the tasking
21709 -- run time active for the pragma Priority to have any effect.
21710 -- Previously we with'ed the package System.Tasking, but this
21711 -- package does not trigger the required initialization of the
21712 -- run-time library.
21714 if Restricted_Profile
then
21715 Discard_Node
(RTE
(RE_Activate_Restricted_Tasks
));
21717 Discard_Node
(RTE
(RE_Activate_Tasks
));
21720 -- Task or Protected, must be of type Integer
21722 elsif Nkind
(P
) in N_Protected_Definition | N_Task_Definition
then
21723 Arg
:= Get_Pragma_Arg
(Arg1
);
21724 Ent
:= Defining_Identifier
(Parent
(P
));
21726 -- The expression must be analyzed in the special manner
21727 -- described in "Handling of Default and Per-Object
21728 -- Expressions" in sem.ads.
21730 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
21732 if not Is_OK_Static_Expression
(Arg
) then
21733 Check_Restriction
(Static_Priorities
, Arg
);
21736 -- Anything else is incorrect
21742 -- Check duplicate pragma before we chain the pragma in the Rep
21743 -- Item chain of Ent.
21745 Check_Duplicate_Pragma
(Ent
);
21746 Record_Rep_Item
(Ent
, N
);
21749 -----------------------------------
21750 -- Priority_Specific_Dispatching --
21751 -----------------------------------
21753 -- pragma Priority_Specific_Dispatching (
21754 -- policy_IDENTIFIER,
21755 -- first_priority_EXPRESSION,
21756 -- last_priority_EXPRESSION);
21758 when Pragma_Priority_Specific_Dispatching
=>
21759 Priority_Specific_Dispatching
: declare
21760 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
21761 -- This is the entity System.Any_Priority;
21764 Lower_Bound
: Node_Id
;
21765 Upper_Bound
: Node_Id
;
21771 Check_Arg_Count
(3);
21772 Check_No_Identifiers
;
21773 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21774 Check_Valid_Configuration_Pragma
;
21775 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21776 DP
:= Fold_Upper
(Name_Buffer
(1));
21778 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
21779 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
21780 Lower_Val
:= Expr_Value
(Lower_Bound
);
21782 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
21783 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
21784 Upper_Val
:= Expr_Value
(Upper_Bound
);
21786 -- It is not allowed to use Task_Dispatching_Policy and
21787 -- Priority_Specific_Dispatching in the same partition.
21789 if Task_Dispatching_Policy
/= ' ' then
21790 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21792 ("pragma% incompatible with Task_Dispatching_Policy#");
21794 -- Check lower bound in range
21796 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21798 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21801 ("first_priority is out of range", Arg2
);
21803 -- Check upper bound in range
21805 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21807 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21810 ("last_priority is out of range", Arg3
);
21812 -- Check that the priority range is valid
21814 elsif Lower_Val
> Upper_Val
then
21816 ("last_priority_expression must be greater than or equal to "
21817 & "first_priority_expression");
21819 -- Store the new policy, but always preserve System_Location since
21820 -- we like the error message with the run-time name.
21823 -- Check overlapping in the priority ranges specified in other
21824 -- Priority_Specific_Dispatching pragmas within the same
21825 -- partition. We can only check those we know about.
21828 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
21830 if Specific_Dispatching
.Table
(J
).First_Priority
in
21831 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21832 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
21833 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21836 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
21838 ("priority range overlaps with "
21839 & "Priority_Specific_Dispatching#");
21843 -- The use of Priority_Specific_Dispatching is incompatible
21844 -- with Task_Dispatching_Policy.
21846 if Task_Dispatching_Policy
/= ' ' then
21847 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21849 ("Priority_Specific_Dispatching incompatible "
21850 & "with Task_Dispatching_Policy#");
21853 -- The use of Priority_Specific_Dispatching forces ceiling
21856 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
21857 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
21859 ("Priority_Specific_Dispatching incompatible "
21860 & "with Locking_Policy#");
21862 -- Set the Ceiling_Locking policy, but preserve System_Location
21863 -- since we like the error message with the run time name.
21866 Locking_Policy
:= 'C';
21868 if Locking_Policy_Sloc
/= System_Location
then
21869 Locking_Policy_Sloc
:= Loc
;
21873 -- Add entry in the table
21875 Specific_Dispatching
.Append
21876 ((Dispatching_Policy
=> DP
,
21877 First_Priority
=> UI_To_Int
(Lower_Val
),
21878 Last_Priority
=> UI_To_Int
(Upper_Val
),
21879 Pragma_Loc
=> Loc
));
21881 end Priority_Specific_Dispatching
;
21887 -- pragma Profile (profile_IDENTIFIER);
21889 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21891 when Pragma_Profile
=>
21893 Check_Arg_Count
(1);
21894 Check_Valid_Configuration_Pragma
;
21895 Check_No_Identifiers
;
21898 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21901 if Nkind
(Argx
) /= N_Identifier
then
21903 ("argument of pragma Profile must be an identifier", N
);
21905 elsif Chars
(Argx
) = Name_Ravenscar
then
21906 Set_Ravenscar_Profile
(Ravenscar
, N
);
21908 elsif Chars
(Argx
) = Name_Jorvik
then
21909 Set_Ravenscar_Profile
(Jorvik
, N
);
21911 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
21912 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
21914 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
21915 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
21917 elsif Chars
(Argx
) = Name_Restricted
then
21918 Set_Profile_Restrictions
21920 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21922 elsif Chars
(Argx
) = Name_Rational
then
21923 Set_Rational_Profile
;
21925 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21926 Set_Profile_Restrictions
21927 (No_Implementation_Extensions
,
21928 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21931 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21935 ----------------------
21936 -- Profile_Warnings --
21937 ----------------------
21939 -- pragma Profile_Warnings (profile_IDENTIFIER);
21941 -- profile_IDENTIFIER => Restricted | Ravenscar
21943 when Pragma_Profile_Warnings
=>
21945 Check_Arg_Count
(1);
21946 Check_Valid_Configuration_Pragma
;
21947 Check_No_Identifiers
;
21950 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21953 if Chars
(Argx
) = Name_Ravenscar
then
21954 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
21956 elsif Chars
(Argx
) = Name_Restricted
then
21957 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
21959 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21960 Set_Profile_Restrictions
21961 (No_Implementation_Extensions
, N
, Warn
=> True);
21964 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21968 --------------------------
21969 -- Propagate_Exceptions --
21970 --------------------------
21972 -- pragma Propagate_Exceptions;
21974 -- Note: this pragma is obsolete and has no effect
21976 when Pragma_Propagate_Exceptions
=>
21978 Check_Arg_Count
(0);
21980 if Warn_On_Obsolescent_Feature
then
21982 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21983 "and has no effect?j?", N
);
21986 -----------------------------
21987 -- Provide_Shift_Operators --
21988 -----------------------------
21990 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21992 when Pragma_Provide_Shift_Operators
=>
21993 Provide_Shift_Operators
: declare
21996 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21997 -- Insert declaration and pragma Instrinsic for named shift op
21999 ----------------------------
22000 -- Declare_Shift_Operator --
22001 ----------------------------
22003 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
22009 Make_Subprogram_Declaration
(Loc
,
22010 Make_Function_Specification
(Loc
,
22011 Defining_Unit_Name
=>
22012 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
22014 Result_Definition
=>
22015 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
22017 Parameter_Specifications
=> New_List
(
22018 Make_Parameter_Specification
(Loc
,
22019 Defining_Identifier
=>
22020 Make_Defining_Identifier
(Loc
, Name_Value
),
22022 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
22024 Make_Parameter_Specification
(Loc
,
22025 Defining_Identifier
=>
22026 Make_Defining_Identifier
(Loc
, Name_Amount
),
22028 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
22032 Chars
=> Name_Import
,
22033 Pragma_Argument_Associations
=> New_List
(
22034 Make_Pragma_Argument_Association
(Loc
,
22035 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
22036 Make_Pragma_Argument_Association
(Loc
,
22037 Expression
=> Make_Identifier
(Loc
, Nam
))));
22039 Insert_After
(N
, Import
);
22040 Insert_After
(N
, Func
);
22041 end Declare_Shift_Operator
;
22043 -- Start of processing for Provide_Shift_Operators
22047 Check_Arg_Count
(1);
22048 Check_Arg_Is_Local_Name
(Arg1
);
22050 Arg1
:= Get_Pragma_Arg
(Arg1
);
22052 -- We must have an entity name
22054 if not Is_Entity_Name
(Arg1
) then
22056 ("pragma % must apply to integer first subtype", Arg1
);
22059 -- If no Entity, means there was a prior error so ignore
22061 if Present
(Entity
(Arg1
)) then
22062 Ent
:= Entity
(Arg1
);
22064 -- Apply error checks
22066 if not Is_First_Subtype
(Ent
) then
22068 ("cannot apply pragma %",
22069 "\& is not a first subtype",
22072 elsif not Is_Integer_Type
(Ent
) then
22074 ("cannot apply pragma %",
22075 "\& is not an integer type",
22078 elsif Has_Shift_Operator
(Ent
) then
22080 ("cannot apply pragma %",
22081 "\& already has declared shift operators",
22084 elsif Is_Frozen
(Ent
) then
22086 ("pragma % appears too late",
22087 "\& is already frozen",
22091 -- Now declare the operators. We do this during analysis rather
22092 -- than expansion, since we want the operators available if we
22093 -- are operating in -gnatc mode.
22095 Declare_Shift_Operator
(Name_Rotate_Left
);
22096 Declare_Shift_Operator
(Name_Rotate_Right
);
22097 Declare_Shift_Operator
(Name_Shift_Left
);
22098 Declare_Shift_Operator
(Name_Shift_Right
);
22099 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
22101 end Provide_Shift_Operators
;
22107 -- pragma Psect_Object (
22108 -- [Internal =>] LOCAL_NAME,
22109 -- [, [External =>] EXTERNAL_SYMBOL]
22110 -- [, [Size =>] EXTERNAL_SYMBOL]);
22112 when Pragma_Common_Object
22113 | Pragma_Psect_Object
22115 Psect_Object
: declare
22116 Args
: Args_List
(1 .. 3);
22117 Names
: constant Name_List
(1 .. 3) := (
22122 Internal
: Node_Id
renames Args
(1);
22123 External
: Node_Id
renames Args
(2);
22124 Size
: Node_Id
renames Args
(3);
22126 Def_Id
: Entity_Id
;
22128 procedure Check_Arg
(Arg
: Node_Id
);
22129 -- Checks that argument is either a string literal or an
22130 -- identifier, and posts error message if not.
22136 procedure Check_Arg
(Arg
: Node_Id
) is
22138 if Nkind
(Original_Node
(Arg
)) not in
22139 N_String_Literal | N_Identifier
22142 ("inappropriate argument for pragma %", Arg
);
22146 -- Start of processing for Common_Object/Psect_Object
22150 Gather_Associations
(Names
, Args
);
22151 Process_Extended_Import_Export_Internal_Arg
(Internal
);
22153 Def_Id
:= Entity
(Internal
);
22155 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
22157 ("pragma% must designate an object", Internal
);
22160 Check_Arg
(Internal
);
22162 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
22164 ("cannot use pragma% for imported/exported object",
22168 if Is_Concurrent_Type
(Etype
(Internal
)) then
22170 ("cannot specify pragma % for task/protected object",
22174 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
22176 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
22178 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
22181 if Ekind
(Def_Id
) = E_Constant
then
22183 ("cannot specify pragma % for a constant", Internal
);
22186 if Is_Record_Type
(Etype
(Internal
)) then
22192 Ent
:= First_Entity
(Etype
(Internal
));
22193 while Present
(Ent
) loop
22194 Decl
:= Declaration_Node
(Ent
);
22196 if Ekind
(Ent
) = E_Component
22197 and then Nkind
(Decl
) = N_Component_Declaration
22198 and then Present
(Expression
(Decl
))
22199 and then Warn_On_Export_Import
22202 ("?x?object for pragma % has defaults", Internal
);
22212 if Present
(Size
) then
22216 if Present
(External
) then
22217 Check_Arg_Is_External_Name
(External
);
22220 -- If all error tests pass, link pragma on to the rep item chain
22222 Record_Rep_Item
(Def_Id
, N
);
22229 -- pragma Pure [(library_unit_NAME)];
22231 when Pragma_Pure
=> Pure
: declare
22235 Check_Ada_83_Warning
;
22237 -- If the pragma comes from a subprogram instantiation, nothing to
22238 -- check, this can happen at any level of nesting.
22240 if Is_Wrapper_Package
(Current_Scope
) then
22244 Check_Valid_Library_Unit_Pragma
;
22246 -- If N was rewritten as a null statement there is nothing more
22249 if Nkind
(N
) = N_Null_Statement
then
22253 Ent
:= Find_Lib_Unit_Name
;
22255 -- A pragma that applies to a Ghost entity becomes Ghost for the
22256 -- purposes of legality checks and removal of ignored Ghost code.
22258 Mark_Ghost_Pragma
(N
, Ent
);
22260 if not Debug_Flag_U
then
22262 Set_Has_Pragma_Pure
(Ent
);
22264 if Legacy_Elaboration_Checks
then
22265 Set_Suppress_Elaboration_Warnings
(Ent
);
22270 -------------------
22271 -- Pure_Function --
22272 -------------------
22274 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22276 when Pragma_Pure_Function
=> Pure_Function
: declare
22277 Def_Id
: Entity_Id
;
22280 Effective
: Boolean := False;
22281 Orig_Def
: Entity_Id
;
22282 Same_Decl
: Boolean := False;
22286 Check_Arg_Count
(1);
22287 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22288 Check_Arg_Is_Local_Name
(Arg1
);
22289 E_Id
:= Get_Pragma_Arg
(Arg1
);
22291 if Etype
(E_Id
) = Any_Type
then
22295 -- Loop through homonyms (overloadings) of referenced entity
22297 E
:= Entity
(E_Id
);
22299 -- A pragma that applies to a Ghost entity becomes Ghost for the
22300 -- purposes of legality checks and removal of ignored Ghost code.
22302 Mark_Ghost_Pragma
(N
, E
);
22304 if Present
(E
) then
22306 Def_Id
:= Get_Base_Subprogram
(E
);
22308 if Ekind
(Def_Id
) not in
22309 E_Function | E_Generic_Function | E_Operator
22312 ("pragma% requires a function name", Arg1
);
22315 -- When we have a generic function we must jump up a level
22316 -- to the declaration of the wrapper package itself.
22318 Orig_Def
:= Def_Id
;
22320 if Is_Generic_Instance
(Def_Id
) then
22321 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
22322 Orig_Def
:= Parent
(Orig_Def
);
22326 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
22328 Set_Is_Pure
(Def_Id
);
22330 if not Has_Pragma_Pure_Function
(Def_Id
) then
22331 Set_Has_Pragma_Pure_Function
(Def_Id
);
22336 exit when From_Aspect_Specification
(N
);
22338 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
22342 and then Warn_On_Redundant_Constructs
22345 ("pragma Pure_Function on& is redundant?r?",
22348 elsif not Same_Decl
then
22350 ("pragma% argument must be in same declarative part",
22356 --------------------
22357 -- Queuing_Policy --
22358 --------------------
22360 -- pragma Queuing_Policy (policy_IDENTIFIER);
22362 when Pragma_Queuing_Policy
=> declare
22366 Check_Ada_83_Warning
;
22367 Check_Arg_Count
(1);
22368 Check_No_Identifiers
;
22369 Check_Arg_Is_Queuing_Policy
(Arg1
);
22370 Check_Valid_Configuration_Pragma
;
22371 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22372 QP
:= Fold_Upper
(Name_Buffer
(1));
22374 if Queuing_Policy
/= ' '
22375 and then Queuing_Policy
/= QP
22377 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
22378 Error_Pragma
("queuing policy incompatible with policy#");
22380 -- Set new policy, but always preserve System_Location since we
22381 -- like the error message with the run time name.
22384 Queuing_Policy
:= QP
;
22386 if Queuing_Policy_Sloc
/= System_Location
then
22387 Queuing_Policy_Sloc
:= Loc
;
22396 -- pragma Rational, for compatibility with foreign compiler
22398 when Pragma_Rational
=>
22399 Set_Rational_Profile
;
22401 ---------------------
22402 -- Refined_Depends --
22403 ---------------------
22405 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22407 -- DEPENDENCY_RELATION ::=
22409 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22411 -- DEPENDENCY_CLAUSE ::=
22412 -- OUTPUT_LIST =>[+] INPUT_LIST
22413 -- | NULL_DEPENDENCY_CLAUSE
22415 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22417 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22419 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22421 -- OUTPUT ::= NAME | FUNCTION_RESULT
22424 -- where FUNCTION_RESULT is a function Result attribute_reference
22426 -- Characteristics:
22428 -- * Analysis - The annotation undergoes initial checks to verify
22429 -- the legal placement and context. Secondary checks fully analyze
22430 -- the dependency clauses/global list in:
22432 -- Analyze_Refined_Depends_In_Decl_Part
22434 -- * Expansion - None.
22436 -- * Template - The annotation utilizes the generic template of the
22437 -- related subprogram body.
22439 -- * Globals - Capture of global references must occur after full
22442 -- * Instance - The annotation is instantiated automatically when
22443 -- the related generic subprogram body is instantiated.
22445 when Pragma_Refined_Depends
=> Refined_Depends
: declare
22446 Body_Id
: Entity_Id
;
22448 Spec_Id
: Entity_Id
;
22451 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22455 -- Chain the pragma on the contract for further processing by
22456 -- Analyze_Refined_Depends_In_Decl_Part.
22458 Add_Contract_Item
(N
, Body_Id
);
22460 -- The legality checks of pragmas Refined_Depends and
22461 -- Refined_Global are affected by the SPARK mode in effect and
22462 -- the volatility of the context. In addition these two pragmas
22463 -- are subject to an inherent order:
22465 -- 1) Refined_Global
22466 -- 2) Refined_Depends
22468 -- Analyze all these pragmas in the order outlined above
22470 Analyze_If_Present
(Pragma_SPARK_Mode
);
22471 Analyze_If_Present
(Pragma_Volatile_Function
);
22472 Analyze_If_Present
(Pragma_Refined_Global
);
22473 Analyze_Refined_Depends_In_Decl_Part
(N
);
22475 end Refined_Depends
;
22477 --------------------
22478 -- Refined_Global --
22479 --------------------
22481 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22483 -- GLOBAL_SPECIFICATION ::=
22486 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22488 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22490 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22491 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22492 -- GLOBAL_ITEM ::= NAME
22494 -- Characteristics:
22496 -- * Analysis - The annotation undergoes initial checks to verify
22497 -- the legal placement and context. Secondary checks fully analyze
22498 -- the dependency clauses/global list in:
22500 -- Analyze_Refined_Global_In_Decl_Part
22502 -- * Expansion - None.
22504 -- * Template - The annotation utilizes the generic template of the
22505 -- related subprogram body.
22507 -- * Globals - Capture of global references must occur after full
22510 -- * Instance - The annotation is instantiated automatically when
22511 -- the related generic subprogram body is instantiated.
22513 when Pragma_Refined_Global
=> Refined_Global
: declare
22514 Body_Id
: Entity_Id
;
22516 Spec_Id
: Entity_Id
;
22519 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22523 -- Chain the pragma on the contract for further processing by
22524 -- Analyze_Refined_Global_In_Decl_Part.
22526 Add_Contract_Item
(N
, Body_Id
);
22528 -- The legality checks of pragmas Refined_Depends and
22529 -- Refined_Global are affected by the SPARK mode in effect and
22530 -- the volatility of the context. In addition these two pragmas
22531 -- are subject to an inherent order:
22533 -- 1) Refined_Global
22534 -- 2) Refined_Depends
22536 -- Analyze all these pragmas in the order outlined above
22538 Analyze_If_Present
(Pragma_SPARK_Mode
);
22539 Analyze_If_Present
(Pragma_Volatile_Function
);
22540 Analyze_Refined_Global_In_Decl_Part
(N
);
22541 Analyze_If_Present
(Pragma_Refined_Depends
);
22543 end Refined_Global
;
22549 -- pragma Refined_Post (boolean_EXPRESSION);
22551 -- Characteristics:
22553 -- * Analysis - The annotation is fully analyzed immediately upon
22554 -- elaboration as it cannot forward reference entities.
22556 -- * Expansion - The annotation is expanded during the expansion of
22557 -- the related subprogram body contract as performed in:
22559 -- Expand_Subprogram_Contract
22561 -- * Template - The annotation utilizes the generic template of the
22562 -- related subprogram body.
22564 -- * Globals - Capture of global references must occur after full
22567 -- * Instance - The annotation is instantiated automatically when
22568 -- the related generic subprogram body is instantiated.
22570 when Pragma_Refined_Post
=> Refined_Post
: declare
22571 Body_Id
: Entity_Id
;
22573 Spec_Id
: Entity_Id
;
22576 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22578 -- Fully analyze the pragma when it appears inside a subprogram
22579 -- body because it cannot benefit from forward references.
22583 -- Chain the pragma on the contract for completeness
22585 Add_Contract_Item
(N
, Body_Id
);
22587 -- The legality checks of pragma Refined_Post are affected by
22588 -- the SPARK mode in effect and the volatility of the context.
22589 -- Analyze all pragmas in a specific order.
22591 Analyze_If_Present
(Pragma_SPARK_Mode
);
22592 Analyze_If_Present
(Pragma_Volatile_Function
);
22593 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
22595 -- Currently it is not possible to inline pre/postconditions on
22596 -- a subprogram subject to pragma Inline_Always.
22598 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
22602 -------------------
22603 -- Refined_State --
22604 -------------------
22606 -- pragma Refined_State (REFINEMENT_LIST);
22608 -- REFINEMENT_LIST ::=
22609 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22611 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22613 -- CONSTITUENT_LIST ::=
22616 -- | (CONSTITUENT {, CONSTITUENT})
22618 -- CONSTITUENT ::= object_NAME | state_NAME
22620 -- Characteristics:
22622 -- * Analysis - The annotation undergoes initial checks to verify
22623 -- the legal placement and context. Secondary checks preanalyze the
22624 -- refinement clauses in:
22626 -- Analyze_Refined_State_In_Decl_Part
22628 -- * Expansion - None.
22630 -- * Template - The annotation utilizes the template of the related
22633 -- * Globals - Capture of global references must occur after full
22636 -- * Instance - The annotation is instantiated automatically when
22637 -- the related generic package body is instantiated.
22639 when Pragma_Refined_State
=> Refined_State
: declare
22640 Pack_Decl
: Node_Id
;
22641 Spec_Id
: Entity_Id
;
22645 Check_No_Identifiers
;
22646 Check_Arg_Count
(1);
22648 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
22650 if Nkind
(Pack_Decl
) /= N_Package_Body
then
22654 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
22656 -- A pragma that applies to a Ghost entity becomes Ghost for the
22657 -- purposes of legality checks and removal of ignored Ghost code.
22659 Mark_Ghost_Pragma
(N
, Spec_Id
);
22661 -- Chain the pragma on the contract for further processing by
22662 -- Analyze_Refined_State_In_Decl_Part.
22664 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
22666 -- The legality checks of pragma Refined_State are affected by the
22667 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22669 Analyze_If_Present
(Pragma_SPARK_Mode
);
22671 -- State refinement is allowed only when the corresponding package
22672 -- declaration has non-null pragma Abstract_State. Refinement not
22673 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22675 if SPARK_Mode
/= Off
22677 (No
(Abstract_States
(Spec_Id
))
22678 or else Has_Null_Abstract_State
(Spec_Id
))
22681 ("useless refinement, package & does not define abstract "
22682 & "states", N
, Spec_Id
);
22687 -----------------------
22688 -- Relative_Deadline --
22689 -----------------------
22691 -- pragma Relative_Deadline (time_span_EXPRESSION);
22693 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
22694 P
: constant Node_Id
:= Parent
(N
);
22699 Check_No_Identifiers
;
22700 Check_Arg_Count
(1);
22702 Arg
:= Get_Pragma_Arg
(Arg1
);
22704 -- The expression must be analyzed in the special manner described
22705 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22707 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
22711 if Nkind
(P
) = N_Subprogram_Body
then
22712 Check_In_Main_Program
;
22714 -- Only Task and subprogram cases allowed
22716 elsif Nkind
(P
) /= N_Task_Definition
then
22720 -- Check duplicate pragma before we set the corresponding flag
22722 if Has_Relative_Deadline_Pragma
(P
) then
22723 Error_Pragma
("duplicate pragma% not allowed");
22726 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22727 -- Relative_Deadline pragma node cannot be inserted in the Rep
22728 -- Item chain of Ent since it is rewritten by the expander as a
22729 -- procedure call statement that will break the chain.
22731 Set_Has_Relative_Deadline_Pragma
(P
);
22732 end Relative_Deadline
;
22734 ------------------------
22735 -- Remote_Access_Type --
22736 ------------------------
22738 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22740 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
22745 Check_Arg_Count
(1);
22746 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22747 Check_Arg_Is_Local_Name
(Arg1
);
22749 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
22751 -- A pragma that applies to a Ghost entity becomes Ghost for the
22752 -- purposes of legality checks and removal of ignored Ghost code.
22754 Mark_Ghost_Pragma
(N
, E
);
22756 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
22757 and then Ekind
(E
) = E_General_Access_Type
22758 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
22759 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
22761 and then Is_Valid_Remote_Object_Type
22762 (Root_Type
(Directly_Designated_Type
(E
)))
22764 Set_Is_Remote_Types
(E
);
22768 ("pragma% applies only to formal access-to-class-wide types",
22771 end Remote_Access_Type
;
22773 ---------------------------
22774 -- Remote_Call_Interface --
22775 ---------------------------
22777 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22779 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
22780 Cunit_Node
: Node_Id
;
22781 Cunit_Ent
: Entity_Id
;
22785 Check_Ada_83_Warning
;
22786 Check_Valid_Library_Unit_Pragma
;
22788 -- If N was rewritten as a null statement there is nothing more
22791 if Nkind
(N
) = N_Null_Statement
then
22795 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22796 K
:= Nkind
(Unit
(Cunit_Node
));
22797 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22799 -- A pragma that applies to a Ghost entity becomes Ghost for the
22800 -- purposes of legality checks and removal of ignored Ghost code.
22802 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22804 if K
= N_Package_Declaration
22805 or else K
= N_Generic_Package_Declaration
22806 or else K
= N_Subprogram_Declaration
22807 or else K
= N_Generic_Subprogram_Declaration
22808 or else (K
= N_Subprogram_Body
22809 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
22814 "pragma% must apply to package or subprogram declaration");
22817 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
22818 end Remote_Call_Interface
;
22824 -- pragma Remote_Types [(library_unit_NAME)];
22826 when Pragma_Remote_Types
=> Remote_Types
: declare
22827 Cunit_Node
: Node_Id
;
22828 Cunit_Ent
: Entity_Id
;
22831 Check_Ada_83_Warning
;
22832 Check_Valid_Library_Unit_Pragma
;
22834 -- If N was rewritten as a null statement there is nothing more
22837 if Nkind
(N
) = N_Null_Statement
then
22841 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22842 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22844 -- A pragma that applies to a Ghost entity becomes Ghost for the
22845 -- purposes of legality checks and removal of ignored Ghost code.
22847 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22849 if Nkind
(Unit
(Cunit_Node
)) not in
22850 N_Package_Declaration | N_Generic_Package_Declaration
22853 ("pragma% can only apply to a package declaration");
22856 Set_Is_Remote_Types
(Cunit_Ent
);
22863 -- pragma Ravenscar;
22865 when Pragma_Ravenscar
=>
22867 Check_Arg_Count
(0);
22868 Check_Valid_Configuration_Pragma
;
22869 Set_Ravenscar_Profile
(Ravenscar
, N
);
22871 if Warn_On_Obsolescent_Feature
then
22873 ("pragma Ravenscar is an obsolescent feature?j?", N
);
22875 ("|use pragma Profile (Ravenscar) instead?j?", N
);
22878 -------------------------
22879 -- Restricted_Run_Time --
22880 -------------------------
22882 -- pragma Restricted_Run_Time;
22884 when Pragma_Restricted_Run_Time
=>
22886 Check_Arg_Count
(0);
22887 Check_Valid_Configuration_Pragma
;
22888 Set_Profile_Restrictions
22889 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
22891 if Warn_On_Obsolescent_Feature
then
22893 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22896 ("|use pragma Profile (Restricted) instead?j?", N
);
22903 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22906 -- restriction_IDENTIFIER
22907 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22909 when Pragma_Restrictions
=>
22910 Process_Restrictions_Or_Restriction_Warnings
22911 (Warn
=> Treat_Restrictions_As_Warnings
);
22913 --------------------------
22914 -- Restriction_Warnings --
22915 --------------------------
22917 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22920 -- restriction_IDENTIFIER
22921 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22923 when Pragma_Restriction_Warnings
=>
22925 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
22931 -- pragma Reviewable;
22933 when Pragma_Reviewable
=>
22934 Check_Ada_83_Warning
;
22935 Check_Arg_Count
(0);
22937 -- Call dummy debugging function rv. This is done to assist front
22938 -- end debugging. By placing a Reviewable pragma in the source
22939 -- program, a breakpoint on rv catches this place in the source,
22940 -- allowing convenient stepping to the point of interest.
22944 --------------------------
22945 -- Secondary_Stack_Size --
22946 --------------------------
22948 -- pragma Secondary_Stack_Size (EXPRESSION);
22950 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
22951 P
: constant Node_Id
:= Parent
(N
);
22957 Check_No_Identifiers
;
22958 Check_Arg_Count
(1);
22960 if Nkind
(P
) = N_Task_Definition
then
22961 Arg
:= Get_Pragma_Arg
(Arg1
);
22962 Ent
:= Defining_Identifier
(Parent
(P
));
22964 -- The expression must be analyzed in the special manner
22965 -- described in "Handling of Default Expressions" in sem.ads.
22967 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22969 -- The pragma cannot appear if the No_Secondary_Stack
22970 -- restriction is in effect.
22972 Check_Restriction
(No_Secondary_Stack
, Arg
);
22974 -- Anything else is incorrect
22980 -- Check duplicate pragma before we chain the pragma in the Rep
22981 -- Item chain of Ent.
22983 Check_Duplicate_Pragma
(Ent
);
22984 Record_Rep_Item
(Ent
, N
);
22985 end Secondary_Stack_Size
;
22987 --------------------------
22988 -- Short_Circuit_And_Or --
22989 --------------------------
22991 -- pragma Short_Circuit_And_Or;
22993 when Pragma_Short_Circuit_And_Or
=>
22995 Check_Arg_Count
(0);
22996 Check_Valid_Configuration_Pragma
;
22997 Short_Circuit_And_Or
:= True;
22999 -------------------
23000 -- Share_Generic --
23001 -------------------
23003 -- pragma Share_Generic (GNAME {, GNAME});
23005 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23007 when Pragma_Share_Generic
=>
23009 Process_Generic_List
;
23015 -- pragma Shared (LOCAL_NAME);
23017 when Pragma_Shared
=>
23019 Process_Atomic_Independent_Shared_Volatile
;
23021 --------------------
23022 -- Shared_Passive --
23023 --------------------
23025 -- pragma Shared_Passive [(library_unit_NAME)];
23027 -- Set the flag Is_Shared_Passive of program unit name entity
23029 when Pragma_Shared_Passive
=> Shared_Passive
: declare
23030 Cunit_Node
: Node_Id
;
23031 Cunit_Ent
: Entity_Id
;
23034 Check_Ada_83_Warning
;
23035 Check_Valid_Library_Unit_Pragma
;
23037 -- If N was rewritten as a null statement there is nothing more
23040 if Nkind
(N
) = N_Null_Statement
then
23044 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23045 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23047 -- A pragma that applies to a Ghost entity becomes Ghost for the
23048 -- purposes of legality checks and removal of ignored Ghost code.
23050 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23052 if Nkind
(Unit
(Cunit_Node
)) not in
23053 N_Package_Declaration | N_Generic_Package_Declaration
23056 ("pragma% can only apply to a package declaration");
23059 Set_Is_Shared_Passive
(Cunit_Ent
);
23060 end Shared_Passive
;
23062 -----------------------
23063 -- Short_Descriptors --
23064 -----------------------
23066 -- pragma Short_Descriptors;
23068 -- Recognize and validate, but otherwise ignore
23070 when Pragma_Short_Descriptors
=>
23072 Check_Arg_Count
(0);
23073 Check_Valid_Configuration_Pragma
;
23075 ------------------------------
23076 -- Simple_Storage_Pool_Type --
23077 ------------------------------
23079 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23081 when Pragma_Simple_Storage_Pool_Type
=>
23082 Simple_Storage_Pool_Type
: declare
23088 Check_Arg_Count
(1);
23089 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23091 Type_Id
:= Get_Pragma_Arg
(Arg1
);
23092 Find_Type
(Type_Id
);
23093 Typ
:= Entity
(Type_Id
);
23095 if Typ
= Any_Type
then
23099 -- A pragma that applies to a Ghost entity becomes Ghost for the
23100 -- purposes of legality checks and removal of ignored Ghost code.
23102 Mark_Ghost_Pragma
(N
, Typ
);
23104 -- We require the pragma to apply to a type declared in a package
23105 -- declaration, but not (immediately) within a package body.
23107 if Ekind
(Current_Scope
) /= E_Package
23108 or else In_Package_Body
(Current_Scope
)
23111 ("pragma% can only apply to type declared immediately "
23112 & "within a package declaration");
23115 -- A simple storage pool type must be an immutably limited record
23116 -- or private type. If the pragma is given for a private type,
23117 -- the full type is similarly restricted (which is checked later
23118 -- in Freeze_Entity).
23120 if Is_Record_Type
(Typ
)
23121 and then not Is_Limited_View
(Typ
)
23124 ("pragma% can only apply to explicitly limited record type");
23126 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
23128 ("pragma% can only apply to a private type that is limited");
23130 elsif not Is_Record_Type
(Typ
)
23131 and then not Is_Private_Type
(Typ
)
23134 ("pragma% can only apply to limited record or private type");
23137 Record_Rep_Item
(Typ
, N
);
23138 end Simple_Storage_Pool_Type
;
23140 ----------------------
23141 -- Source_File_Name --
23142 ----------------------
23144 -- There are five forms for this pragma:
23146 -- pragma Source_File_Name (
23147 -- [UNIT_NAME =>] unit_NAME,
23148 -- BODY_FILE_NAME => STRING_LITERAL
23149 -- [, [INDEX =>] INTEGER_LITERAL]);
23151 -- pragma Source_File_Name (
23152 -- [UNIT_NAME =>] unit_NAME,
23153 -- SPEC_FILE_NAME => STRING_LITERAL
23154 -- [, [INDEX =>] INTEGER_LITERAL]);
23156 -- pragma Source_File_Name (
23157 -- BODY_FILE_NAME => STRING_LITERAL
23158 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23159 -- [, CASING => CASING_SPEC]);
23161 -- pragma Source_File_Name (
23162 -- SPEC_FILE_NAME => STRING_LITERAL
23163 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23164 -- [, CASING => CASING_SPEC]);
23166 -- pragma Source_File_Name (
23167 -- SUBUNIT_FILE_NAME => STRING_LITERAL
23168 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23169 -- [, CASING => CASING_SPEC]);
23171 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
23173 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
23174 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
23175 -- only be used when no project file is used, while SFNP can only be
23176 -- used when a project file is used.
23178 -- No processing here. Processing was completed during parsing, since
23179 -- we need to have file names set as early as possible. Units are
23180 -- loaded well before semantic processing starts.
23182 -- The only processing we defer to this point is the check for
23183 -- correct placement.
23185 when Pragma_Source_File_Name
=>
23187 Check_Valid_Configuration_Pragma
;
23189 ------------------------------
23190 -- Source_File_Name_Project --
23191 ------------------------------
23193 -- See Source_File_Name for syntax
23195 -- No processing here. Processing was completed during parsing, since
23196 -- we need to have file names set as early as possible. Units are
23197 -- loaded well before semantic processing starts.
23199 -- The only processing we defer to this point is the check for
23200 -- correct placement.
23202 when Pragma_Source_File_Name_Project
=>
23204 Check_Valid_Configuration_Pragma
;
23206 -- Check that a pragma Source_File_Name_Project is used only in a
23207 -- configuration pragmas file.
23209 -- Pragmas Source_File_Name_Project should only be generated by
23210 -- the Project Manager in configuration pragmas files.
23212 -- This is really an ugly test. It seems to depend on some
23213 -- accidental and undocumented property. At the very least it
23214 -- needs to be documented, but it would be better to have a
23215 -- clean way of testing if we are in a configuration file???
23217 if Present
(Parent
(N
)) then
23219 ("pragma% can only appear in a configuration pragmas file");
23222 ----------------------
23223 -- Source_Reference --
23224 ----------------------
23226 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23228 -- Nothing to do, all processing completed in Par.Prag, since we need
23229 -- the information for possible parser messages that are output.
23231 when Pragma_Source_Reference
=>
23238 -- pragma SPARK_Mode [(Auto | On | Off)];
23240 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
23241 Mode_Id
: SPARK_Mode_Type
;
23243 procedure Check_Pragma_Conformance
23244 (Context_Pragma
: Node_Id
;
23245 Entity
: Entity_Id
;
23246 Entity_Pragma
: Node_Id
);
23247 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23248 -- conformance of pragma N depending the following scenarios:
23250 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23251 -- compatible with the pragma Context_Pragma that was inherited
23252 -- from the context:
23253 -- * If the mode of Context_Pragma is ON, then the new mode can
23255 -- * If the mode of Context_Pragma is OFF, then the only allowed
23256 -- new mode is also OFF. Emit error if this is not the case.
23258 -- If Entity is not Empty, verify that pragma N is compatible with
23259 -- pragma Entity_Pragma that belongs to Entity.
23260 -- * If Entity_Pragma is Empty, always issue an error as this
23261 -- corresponds to the case where a previous section of Entity
23262 -- has no SPARK_Mode set.
23263 -- * If the mode of Entity_Pragma is ON, then the new mode can
23265 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23266 -- new mode is also OFF. Emit error if this is not the case.
23268 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
23269 -- Subsidiary to routines Process_xxx. Verify that the related
23270 -- entity E subject to pragma SPARK_Mode is library-level.
23272 procedure Process_Body
(Decl
: Node_Id
);
23273 -- Verify the legality of pragma SPARK_Mode when it appears as the
23274 -- top of the body declarations of entry, package, protected unit,
23275 -- subprogram or task unit body denoted by Decl.
23277 procedure Process_Overloadable
(Decl
: Node_Id
);
23278 -- Verify the legality of pragma SPARK_Mode when it applies to an
23279 -- entry or [generic] subprogram declaration denoted by Decl.
23281 procedure Process_Private_Part
(Decl
: Node_Id
);
23282 -- Verify the legality of pragma SPARK_Mode when it appears at the
23283 -- top of the private declarations of a package spec, protected or
23284 -- task unit declaration denoted by Decl.
23286 procedure Process_Statement_Part
(Decl
: Node_Id
);
23287 -- Verify the legality of pragma SPARK_Mode when it appears at the
23288 -- top of the statement sequence of a package body denoted by node
23291 procedure Process_Visible_Part
(Decl
: Node_Id
);
23292 -- Verify the legality of pragma SPARK_Mode when it appears at the
23293 -- top of the visible declarations of a package spec, protected or
23294 -- task unit declaration denoted by Decl. The routine is also used
23295 -- on protected or task units declared without a definition.
23297 procedure Set_SPARK_Context
;
23298 -- Subsidiary to routines Process_xxx. Set the global variables
23299 -- which represent the mode of the context from pragma N. Ensure
23300 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23302 ------------------------------
23303 -- Check_Pragma_Conformance --
23304 ------------------------------
23306 procedure Check_Pragma_Conformance
23307 (Context_Pragma
: Node_Id
;
23308 Entity
: Entity_Id
;
23309 Entity_Pragma
: Node_Id
)
23311 Err_Id
: Entity_Id
;
23315 -- The current pragma may appear without an argument. If this
23316 -- is the case, associate all error messages with the pragma
23319 if Present
(Arg1
) then
23325 -- The mode of the current pragma is compared against that of
23326 -- an enclosing context.
23328 if Present
(Context_Pragma
) then
23329 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
23331 -- Issue an error if the new mode is less restrictive than
23332 -- that of the context.
23334 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
23335 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23338 ("cannot change SPARK_Mode from Off to On", Err_N
);
23339 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
23340 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
23345 -- The mode of the current pragma is compared against that of
23346 -- an initial package, protected type, subprogram or task type
23349 if Present
(Entity
) then
23351 -- A simple protected or task type is transformed into an
23352 -- anonymous type whose name cannot be used to issue error
23353 -- messages. Recover the original entity of the type.
23355 if Ekind
(Entity
) in E_Protected_Type | E_Task_Type
then
23358 (Original_Node
(Unit_Declaration_Node
(Entity
)));
23363 -- Both the initial declaration and the completion carry
23364 -- SPARK_Mode pragmas.
23366 if Present
(Entity_Pragma
) then
23367 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
23369 -- Issue an error if the new mode is less restrictive
23370 -- than that of the initial declaration.
23372 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
23373 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23375 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23376 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
23378 ("\value Off was set for SPARK_Mode on&#",
23383 -- Otherwise the initial declaration lacks a SPARK_Mode
23384 -- pragma in which case the current pragma is illegal as
23385 -- it cannot "complete".
23387 elsif Get_SPARK_Mode_From_Annotation
(N
) = Off
23388 and then (Is_Generic_Unit
(Entity
) or else In_Instance
)
23393 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23394 Error_Msg_Sloc
:= Sloc
(Err_Id
);
23396 ("\no value was set for SPARK_Mode on&#",
23401 end Check_Pragma_Conformance
;
23403 --------------------------------
23404 -- Check_Library_Level_Entity --
23405 --------------------------------
23407 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
23408 procedure Add_Entity_To_Name_Buffer
;
23409 -- Add the E_Kind of entity E to the name buffer
23411 -------------------------------
23412 -- Add_Entity_To_Name_Buffer --
23413 -------------------------------
23415 procedure Add_Entity_To_Name_Buffer
is
23417 if Ekind
(E
) in E_Entry | E_Entry_Family
then
23418 Add_Str_To_Name_Buffer
("entry");
23420 elsif Ekind
(E
) in E_Generic_Package
23424 Add_Str_To_Name_Buffer
("package");
23426 elsif Ekind
(E
) in E_Protected_Body | E_Protected_Type
then
23427 Add_Str_To_Name_Buffer
("protected type");
23429 elsif Ekind
(E
) in E_Function
23430 | E_Generic_Function
23431 | E_Generic_Procedure
23433 | E_Subprogram_Body
23435 Add_Str_To_Name_Buffer
("subprogram");
23438 pragma Assert
(Ekind
(E
) in E_Task_Body | E_Task_Type
);
23439 Add_Str_To_Name_Buffer
("task type");
23441 end Add_Entity_To_Name_Buffer
;
23445 Msg_1
: constant String := "incorrect placement of pragma%";
23448 -- Start of processing for Check_Library_Level_Entity
23451 -- A SPARK_Mode of On shall only apply to library-level
23452 -- entities, except for those in generic instances, which are
23453 -- ignored (even if the entity gets SPARK_Mode pragma attached
23454 -- in the AST, its effect is not taken into account unless the
23455 -- context already provides SPARK_Mode of On in GNATprove).
23457 if Get_SPARK_Mode_From_Annotation
(N
) = On
23458 and then not Is_Library_Level_Entity
(E
)
23459 and then Instantiation_Location
(Sloc
(N
)) = No_Location
23461 Error_Msg_Name_1
:= Pname
;
23462 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
23465 Add_Str_To_Name_Buffer
("\& is not a library-level ");
23466 Add_Entity_To_Name_Buffer
;
23468 Msg_2
:= Name_Find
;
23469 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
23473 end Check_Library_Level_Entity
;
23479 procedure Process_Body
(Decl
: Node_Id
) is
23480 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23481 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
23484 -- Ignore pragma when applied to the special body created
23485 -- for inlining, recognized by its internal name _Parent; or
23486 -- when applied to the special body created for contracts,
23487 -- recognized by its internal name _Wrapped_Statements.
23489 if Chars
(Body_Id
) in Name_uParent
23490 | Name_uWrapped_Statements
23495 Check_Library_Level_Entity
(Body_Id
);
23497 -- For entry bodies, verify the legality against:
23498 -- * The mode of the context
23499 -- * The mode of the spec (if any)
23501 if Nkind
(Decl
) in N_Entry_Body | N_Subprogram_Body
then
23503 -- A stand-alone subprogram body
23505 if Body_Id
= Spec_Id
then
23506 Check_Pragma_Conformance
23507 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23509 Entity_Pragma
=> Empty
);
23511 -- An entry or subprogram body that completes a previous
23515 Check_Pragma_Conformance
23516 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23518 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23522 Set_SPARK_Pragma
(Body_Id
, N
);
23523 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23525 -- For package bodies, verify the legality against:
23526 -- * The mode of the context
23527 -- * The mode of the private part
23529 -- This case is separated from protected and task bodies
23530 -- because the statement part of the package body inherits
23531 -- the mode of the body declarations.
23533 elsif Nkind
(Decl
) = N_Package_Body
then
23534 Check_Pragma_Conformance
23535 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23537 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23540 Set_SPARK_Pragma
(Body_Id
, N
);
23541 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23542 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23543 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
23545 -- For protected and task bodies, verify the legality against:
23546 -- * The mode of the context
23547 -- * The mode of the private part
23551 (Nkind
(Decl
) in N_Protected_Body | N_Task_Body
);
23553 Check_Pragma_Conformance
23554 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23556 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23559 Set_SPARK_Pragma
(Body_Id
, N
);
23560 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23564 --------------------------
23565 -- Process_Overloadable --
23566 --------------------------
23568 procedure Process_Overloadable
(Decl
: Node_Id
) is
23569 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23570 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
23573 Check_Library_Level_Entity
(Spec_Id
);
23575 -- Verify the legality against:
23576 -- * The mode of the context
23578 Check_Pragma_Conformance
23579 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23581 Entity_Pragma
=> Empty
);
23583 Set_SPARK_Pragma
(Spec_Id
, N
);
23584 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23586 -- When the pragma applies to the anonymous object created for
23587 -- a single task type, decorate the type as well. This scenario
23588 -- arises when the single task type lacks a task definition,
23589 -- therefore there is no issue with respect to a potential
23590 -- pragma SPARK_Mode in the private part.
23592 -- task type Anon_Task_Typ;
23593 -- Obj : Anon_Task_Typ;
23594 -- pragma SPARK_Mode ...;
23596 if Is_Single_Task_Object
(Spec_Id
) then
23597 Set_SPARK_Pragma
(Spec_Typ
, N
);
23598 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
23599 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
23600 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
23602 end Process_Overloadable
;
23604 --------------------------
23605 -- Process_Private_Part --
23606 --------------------------
23608 procedure Process_Private_Part
(Decl
: Node_Id
) is
23609 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23612 Check_Library_Level_Entity
(Spec_Id
);
23614 -- Verify the legality against:
23615 -- * The mode of the visible declarations
23617 Check_Pragma_Conformance
23618 (Context_Pragma
=> Empty
,
23620 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23623 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23624 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
23625 end Process_Private_Part
;
23627 ----------------------------
23628 -- Process_Statement_Part --
23629 ----------------------------
23631 procedure Process_Statement_Part
(Decl
: Node_Id
) is
23632 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23635 Check_Library_Level_Entity
(Body_Id
);
23637 -- Verify the legality against:
23638 -- * The mode of the body declarations
23640 Check_Pragma_Conformance
23641 (Context_Pragma
=> Empty
,
23643 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
23646 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23647 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
23648 end Process_Statement_Part
;
23650 --------------------------
23651 -- Process_Visible_Part --
23652 --------------------------
23654 procedure Process_Visible_Part
(Decl
: Node_Id
) is
23655 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23656 Obj_Id
: Entity_Id
;
23659 Check_Library_Level_Entity
(Spec_Id
);
23661 -- Verify the legality against:
23662 -- * The mode of the context
23664 Check_Pragma_Conformance
23665 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23667 Entity_Pragma
=> Empty
);
23669 -- A task unit declared without a definition does not set the
23670 -- SPARK_Mode of the context because the task does not have any
23671 -- entries that could inherit the mode.
23673 if Nkind
(Decl
) not in
23674 N_Single_Task_Declaration | N_Task_Type_Declaration
23679 Set_SPARK_Pragma
(Spec_Id
, N
);
23680 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23681 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23682 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
23684 -- When the pragma applies to a single protected or task type,
23685 -- decorate the corresponding anonymous object as well.
23687 -- protected Anon_Prot_Typ is
23688 -- pragma SPARK_Mode ...;
23690 -- end Anon_Prot_Typ;
23692 -- Obj : Anon_Prot_Typ;
23694 if Is_Single_Concurrent_Type
(Spec_Id
) then
23695 Obj_Id
:= Anonymous_Object
(Spec_Id
);
23697 Set_SPARK_Pragma
(Obj_Id
, N
);
23698 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
23700 end Process_Visible_Part
;
23702 -----------------------
23703 -- Set_SPARK_Context --
23704 -----------------------
23706 procedure Set_SPARK_Context
is
23708 SPARK_Mode
:= Mode_Id
;
23709 SPARK_Mode_Pragma
:= N
;
23710 end Set_SPARK_Context
;
23718 -- Start of processing for Do_SPARK_Mode
23722 Check_No_Identifiers
;
23723 Check_At_Most_N_Arguments
(1);
23725 -- Check the legality of the mode (no argument = ON)
23727 if Arg_Count
= 1 then
23728 Check_Arg_Is_One_Of
(Arg1
, Name_Auto
, Name_On
, Name_Off
);
23729 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
23734 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
23735 Context
:= Parent
(N
);
23737 -- When a SPARK_Mode pragma appears inside an instantiation whose
23738 -- enclosing context has SPARK_Mode set to "off", the pragma has
23739 -- no semantic effect.
23741 if Ignore_SPARK_Mode_Pragmas_In_Instance
23742 and then Mode_Id
/= Off
23744 Rewrite
(N
, Make_Null_Statement
(Loc
));
23749 -- The pragma appears in a configuration file
23751 if No
(Context
) then
23752 Check_Valid_Configuration_Pragma
;
23754 if Present
(SPARK_Mode_Pragma
) then
23757 Prev
=> SPARK_Mode_Pragma
);
23763 -- The pragma acts as a configuration pragma in a compilation unit
23765 -- pragma SPARK_Mode ...;
23766 -- package Pack is ...;
23768 elsif Nkind
(Context
) = N_Compilation_Unit
23769 and then List_Containing
(N
) = Context_Items
(Context
)
23771 Check_Valid_Configuration_Pragma
;
23774 -- Otherwise the placement of the pragma within the tree dictates
23775 -- its associated construct. Inspect the declarative list where
23776 -- the pragma resides to find a potential construct.
23779 -- An explicit mode of Auto is only allowed as a configuration
23780 -- pragma. Escape "pragma" to avoid replacement with "aspect".
23782 if Mode_Id
= None
then
23784 ("only configuration 'p'r'a'g'm'a% can have value &",
23789 while Present
(Stmt
) loop
23791 -- Skip prior pragmas, but check for duplicates. Note that
23792 -- this also takes care of pragmas generated for aspects.
23794 if Nkind
(Stmt
) = N_Pragma
then
23795 if Pragma_Name
(Stmt
) = Pname
then
23802 -- The pragma applies to an expression function that has
23803 -- already been rewritten into a subprogram declaration.
23805 -- function Expr_Func return ... is (...);
23806 -- pragma SPARK_Mode ...;
23808 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
23809 and then Nkind
(Original_Node
(Stmt
)) =
23810 N_Expression_Function
23812 Process_Overloadable
(Stmt
);
23815 -- The pragma applies to the anonymous object created for a
23816 -- single concurrent type.
23818 -- protected type Anon_Prot_Typ ...;
23819 -- Obj : Anon_Prot_Typ;
23820 -- pragma SPARK_Mode ...;
23822 elsif Nkind
(Stmt
) = N_Object_Declaration
23823 and then Is_Single_Concurrent_Object
23824 (Defining_Entity
(Stmt
))
23826 Process_Overloadable
(Stmt
);
23829 -- Skip internally generated code
23831 elsif not Comes_From_Source
(Stmt
) then
23834 -- The pragma applies to an entry or [generic] subprogram
23838 -- pragma SPARK_Mode ...;
23841 -- procedure Proc ...;
23842 -- pragma SPARK_Mode ...;
23844 elsif Nkind
(Stmt
) in N_Generic_Subprogram_Declaration
23845 | N_Subprogram_Declaration
23846 or else (Nkind
(Stmt
) = N_Entry_Declaration
23847 and then Is_Protected_Type
23848 (Scope
(Defining_Entity
(Stmt
))))
23850 Process_Overloadable
(Stmt
);
23853 -- Otherwise the pragma does not apply to a legal construct
23854 -- or it does not appear at the top of a declarative or a
23855 -- statement list. Issue an error and stop the analysis.
23864 -- The pragma applies to a package or a subprogram that acts as
23865 -- a compilation unit.
23867 -- procedure Proc ...;
23868 -- pragma SPARK_Mode ...;
23870 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
23871 Context
:= Unit
(Parent
(Context
));
23874 -- The pragma appears at the top of entry, package, protected
23875 -- unit, subprogram or task unit body declarations.
23877 -- entry Ent when ... is
23878 -- pragma SPARK_Mode ...;
23880 -- package body Pack is
23881 -- pragma SPARK_Mode ...;
23883 -- procedure Proc ... is
23884 -- pragma SPARK_Mode;
23886 -- protected body Prot is
23887 -- pragma SPARK_Mode ...;
23889 if Nkind
(Context
) in N_Entry_Body
23892 | N_Subprogram_Body
23895 Process_Body
(Context
);
23897 -- The pragma appears at the top of the visible or private
23898 -- declaration of a package spec, protected or task unit.
23901 -- pragma SPARK_Mode ...;
23903 -- pragma SPARK_Mode ...;
23905 -- protected [type] Prot is
23906 -- pragma SPARK_Mode ...;
23908 -- pragma SPARK_Mode ...;
23910 elsif Nkind
(Context
) in N_Package_Specification
23911 | N_Protected_Definition
23912 | N_Task_Definition
23914 if List_Containing
(N
) = Visible_Declarations
(Context
) then
23915 Process_Visible_Part
(Parent
(Context
));
23917 Process_Private_Part
(Parent
(Context
));
23920 -- The pragma appears at the top of package body statements
23922 -- package body Pack is
23924 -- pragma SPARK_Mode;
23926 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
23927 and then Nkind
(Parent
(Context
)) = N_Package_Body
23929 Process_Statement_Part
(Parent
(Context
));
23931 -- The pragma appeared as an aspect of a [generic] subprogram
23932 -- declaration that acts as a compilation unit.
23935 -- procedure Proc ...;
23936 -- pragma SPARK_Mode ...;
23938 elsif Nkind
(Context
) in N_Generic_Subprogram_Declaration
23939 | N_Subprogram_Declaration
23941 Process_Overloadable
(Context
);
23943 -- The pragma does not apply to a legal construct, issue error
23951 --------------------------------
23952 -- Static_Elaboration_Desired --
23953 --------------------------------
23955 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23957 when Pragma_Static_Elaboration_Desired
=>
23959 Check_At_Most_N_Arguments
(1);
23961 if Is_Compilation_Unit
(Current_Scope
)
23962 and then Ekind
(Current_Scope
) = E_Package
23964 Set_Static_Elaboration_Desired
(Current_Scope
, True);
23966 Error_Pragma
("pragma% must apply to a library-level package");
23973 -- pragma Storage_Size (EXPRESSION);
23975 when Pragma_Storage_Size
=> Storage_Size
: declare
23976 P
: constant Node_Id
:= Parent
(N
);
23980 Check_No_Identifiers
;
23981 Check_Arg_Count
(1);
23983 -- The expression must be analyzed in the special manner described
23984 -- in "Handling of Default Expressions" in sem.ads.
23986 Arg
:= Get_Pragma_Arg
(Arg1
);
23987 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23989 if not Is_OK_Static_Expression
(Arg
) then
23990 Check_Restriction
(Static_Storage_Size
, Arg
);
23993 if Nkind
(P
) /= N_Task_Definition
then
23997 if Has_Storage_Size_Pragma
(P
) then
23998 Error_Pragma
("duplicate pragma% not allowed");
24000 Set_Has_Storage_Size_Pragma
(P
, True);
24003 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
24011 -- pragma Storage_Unit (NUMERIC_LITERAL);
24013 -- Only permitted argument is System'Storage_Unit value
24015 when Pragma_Storage_Unit
=>
24016 Check_No_Identifiers
;
24017 Check_Arg_Count
(1);
24018 Check_Arg_Is_Integer_Literal
(Arg1
);
24020 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
24021 UI_From_Int
(Ttypes
.System_Storage_Unit
)
24023 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
24025 ("the only allowed argument for pragma% is ^", Arg1
);
24028 --------------------
24029 -- Stream_Convert --
24030 --------------------
24032 -- pragma Stream_Convert (
24033 -- [Entity =>] type_LOCAL_NAME,
24034 -- [Read =>] function_NAME,
24035 -- [Write =>] function NAME);
24037 when Pragma_Stream_Convert
=> Stream_Convert
: declare
24038 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
24039 -- Check that the given argument is the name of a local function
24040 -- of one argument that is not overloaded earlier in the current
24041 -- local scope. A check is also made that the argument is a
24042 -- function with one parameter.
24044 --------------------------------------
24045 -- Check_OK_Stream_Convert_Function --
24046 --------------------------------------
24048 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
24052 Check_Arg_Is_Local_Name
(Arg
);
24053 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
24055 if Has_Homonym
(Ent
) then
24057 ("argument for pragma% may not be overloaded", Arg
);
24060 if Ekind
(Ent
) /= E_Function
24061 or else No
(First_Formal
(Ent
))
24062 or else Present
(Next_Formal
(First_Formal
(Ent
)))
24065 ("argument for pragma% must be function of one argument",
24067 elsif Is_Abstract_Subprogram
(Ent
) then
24069 ("argument for pragma% cannot be abstract", Arg
);
24071 end Check_OK_Stream_Convert_Function
;
24073 -- Start of processing for Stream_Convert
24077 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
24078 Check_Arg_Count
(3);
24079 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24080 Check_Optional_Identifier
(Arg2
, Name_Read
);
24081 Check_Optional_Identifier
(Arg3
, Name_Write
);
24082 Check_Arg_Is_Local_Name
(Arg1
);
24083 Check_OK_Stream_Convert_Function
(Arg2
);
24084 Check_OK_Stream_Convert_Function
(Arg3
);
24087 Typ
: constant Entity_Id
:=
24088 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
24089 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
24090 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
24093 Check_First_Subtype
(Arg1
);
24095 -- Check for too early or too late. Note that we don't enforce
24096 -- the rule about primitive operations in this case, since, as
24097 -- is the case for explicit stream attributes themselves, these
24098 -- restrictions are not appropriate. Note that the chaining of
24099 -- the pragma by Rep_Item_Too_Late is actually the critical
24100 -- processing done for this pragma.
24102 if Rep_Item_Too_Early
(Typ
, N
)
24104 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
24109 -- Return if previous error
24111 if Etype
(Typ
) = Any_Type
24113 Etype
(Read
) = Any_Type
24115 Etype
(Write
) = Any_Type
24122 if Underlying_Type
(Etype
(Read
)) /= Typ
then
24124 ("incorrect return type for function&", Arg2
);
24127 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
24129 ("incorrect parameter type for function&", Arg3
);
24132 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
24133 Underlying_Type
(Etype
(Write
))
24136 ("result type of & does not match Read parameter type",
24140 end Stream_Convert
;
24146 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24148 -- This is processed by the parser since some of the style checks
24149 -- take place during source scanning and parsing. This means that
24150 -- we don't need to issue error messages here.
24152 when Pragma_Style_Checks
=> Style_Checks
: declare
24153 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
24159 Check_No_Identifiers
;
24161 -- Two argument form
24163 if Arg_Count
= 2 then
24164 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
24171 E_Id
:= Get_Pragma_Arg
(Arg2
);
24174 if not Is_Entity_Name
(E_Id
) then
24176 ("second argument of pragma% must be entity name",
24180 E
:= Entity
(E_Id
);
24182 if not Ignore_Style_Checks_Pragmas
then
24187 Set_Suppress_Style_Checks
24188 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
24189 exit when No
(Homonym
(E
));
24196 -- One argument form
24199 Check_Arg_Count
(1);
24201 if Nkind
(A
) = N_String_Literal
then
24205 Slen
: constant Natural := Natural (String_Length
(S
));
24206 Options
: String (1 .. Slen
);
24212 C
:= Get_String_Char
(S
, Pos
(J
));
24213 exit when not In_Character_Range
(C
);
24214 Options
(J
) := Get_Character
(C
);
24216 -- If at end of string, set options. As per discussion
24217 -- above, no need to check for errors, since we issued
24218 -- them in the parser.
24221 if not Ignore_Style_Checks_Pragmas
then
24222 Set_Style_Check_Options
(Options
);
24232 elsif Nkind
(A
) = N_Identifier
then
24233 if Chars
(A
) = Name_All_Checks
then
24234 if not Ignore_Style_Checks_Pragmas
then
24236 Set_GNAT_Style_Check_Options
;
24238 Set_Default_Style_Check_Options
;
24242 elsif Chars
(A
) = Name_On
then
24243 if not Ignore_Style_Checks_Pragmas
then
24244 Style_Check
:= True;
24247 elsif Chars
(A
) = Name_Off
then
24248 if not Ignore_Style_Checks_Pragmas
then
24249 Style_Check
:= False;
24256 ------------------------
24257 -- Subprogram_Variant --
24258 ------------------------
24260 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_LIST );
24262 -- SUBPROGRAM_VARIANT_LIST ::= STRUCTURAL_SUBPROGRAM_VARIANT_ITEM
24263 -- | NUMERIC_SUBPROGRAM_VARIANT_ITEMS
24264 -- NUMERIC_SUBPROGRAM_VARIANT_ITEMS ::=
24265 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM
24266 -- {, NUMERIC_SUBPROGRAM_VARIANT_ITEM}
24267 -- NUMERIC_SUBPROGRAM_VARIANT_ITEM ::= CHANGE_DIRECTION => EXPRESSION
24268 -- STRUCTURAL_SUBPROGRAM_VARIANT_ITEM ::= Structural => EXPRESSION
24269 -- CHANGE_DIRECTION ::= Increases | Decreases
24271 -- Characteristics:
24273 -- * Analysis - The annotation undergoes initial checks to verify
24274 -- the legal placement and context. Secondary checks preanalyze the
24277 -- Analyze_Subprogram_Variant_In_Decl_Part
24279 -- * Expansion - The annotation is expanded during the expansion of
24280 -- the related subprogram [body] contract as performed in:
24282 -- Expand_Subprogram_Contract
24284 -- * Template - The annotation utilizes the generic template of the
24285 -- related subprogram [body] when it is:
24287 -- aspect on subprogram declaration
24288 -- aspect on stand-alone subprogram body
24289 -- pragma on stand-alone subprogram body
24291 -- The annotation must prepare its own template when it is:
24293 -- pragma on subprogram declaration
24295 -- * Globals - Capture of global references must occur after full
24298 -- * Instance - The annotation is instantiated automatically when
24299 -- the related generic subprogram [body] is instantiated except for
24300 -- the "pragma on subprogram declaration" case. In that scenario
24301 -- the annotation must instantiate itself.
24303 when Pragma_Subprogram_Variant
=> Subprogram_Variant
: declare
24304 Spec_Id
: Entity_Id
;
24305 Subp_Decl
: Node_Id
;
24306 Subp_Spec
: Node_Id
;
24310 Check_No_Identifiers
;
24311 Check_Arg_Count
(1);
24313 -- Ensure the proper placement of the pragma. Subprogram_Variant
24314 -- must be associated with a subprogram declaration or a body that
24318 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
24320 -- Generic subprogram
24322 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
24325 -- Body acts as spec
24327 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
24328 and then No
(Corresponding_Spec
(Subp_Decl
))
24332 -- Body stub acts as spec
24334 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24335 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24341 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
24342 Subp_Spec
:= Specification
(Subp_Decl
);
24344 -- Pragma Subprogram_Variant is forbidden on null procedures,
24345 -- as this may lead to potential ambiguities in behavior when
24346 -- interface null procedures are involved. Also, it just
24347 -- wouldn't make sense, because null procedure is not
24350 if Nkind
(Subp_Spec
) = N_Procedure_Specification
24351 and then Null_Present
(Subp_Spec
)
24353 Error_Msg_N
(Fix_Error
24354 ("pragma % cannot apply to null procedure"), N
);
24362 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
24364 -- A pragma that applies to a Ghost entity becomes Ghost for the
24365 -- purposes of legality checks and removal of ignored Ghost code.
24367 Mark_Ghost_Pragma
(N
, Spec_Id
);
24368 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
24370 -- Chain the pragma on the contract for further processing by
24371 -- Analyze_Subprogram_Variant_In_Decl_Part.
24373 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
24375 -- Fully analyze the pragma when it appears inside a subprogram
24376 -- body because it cannot benefit from forward references.
24378 if Nkind
(Subp_Decl
) in N_Subprogram_Body
24379 | N_Subprogram_Body_Stub
24381 -- The legality checks of pragma Subprogram_Variant are
24382 -- affected by the SPARK mode in effect and the volatility
24383 -- of the context. Analyze all pragmas in a specific order.
24385 Analyze_If_Present
(Pragma_SPARK_Mode
);
24386 Analyze_If_Present
(Pragma_Volatile_Function
);
24387 Analyze_Subprogram_Variant_In_Decl_Part
(N
);
24389 end Subprogram_Variant
;
24395 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24397 when Pragma_Subtitle
=>
24399 Check_Arg_Count
(1);
24400 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
24401 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24408 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24410 when Pragma_Suppress
=>
24411 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
24417 -- pragma Suppress_All;
24419 -- The only check made here is that the pragma has no arguments.
24420 -- There are no placement rules, and the processing required (setting
24421 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24422 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24423 -- then creates and inserts a pragma Suppress (All_Checks).
24425 when Pragma_Suppress_All
=>
24427 Check_Arg_Count
(0);
24429 -------------------------
24430 -- Suppress_Debug_Info --
24431 -------------------------
24433 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24435 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
24436 Nam_Id
: Entity_Id
;
24440 Check_Arg_Count
(1);
24441 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24442 Check_Arg_Is_Local_Name
(Arg1
);
24444 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
24446 -- A pragma that applies to a Ghost entity becomes Ghost for the
24447 -- purposes of legality checks and removal of ignored Ghost code.
24449 Mark_Ghost_Pragma
(N
, Nam_Id
);
24450 Set_Debug_Info_Off
(Nam_Id
);
24451 end Suppress_Debug_Info
;
24453 ----------------------------------
24454 -- Suppress_Exception_Locations --
24455 ----------------------------------
24457 -- pragma Suppress_Exception_Locations;
24459 when Pragma_Suppress_Exception_Locations
=>
24461 Check_Arg_Count
(0);
24462 Check_Valid_Configuration_Pragma
;
24463 Exception_Locations_Suppressed
:= True;
24465 -----------------------------
24466 -- Suppress_Initialization --
24467 -----------------------------
24469 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24471 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
24477 Check_Arg_Count
(1);
24478 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24479 Check_Arg_Is_Local_Name
(Arg1
);
24481 E_Id
:= Get_Pragma_Arg
(Arg1
);
24483 if Etype
(E_Id
) = Any_Type
then
24487 E
:= Entity
(E_Id
);
24489 -- A pragma that applies to a Ghost entity becomes Ghost for the
24490 -- purposes of legality checks and removal of ignored Ghost code.
24492 Mark_Ghost_Pragma
(N
, E
);
24494 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
24496 ("pragma% requires variable, type or subtype", Arg1
);
24499 if Rep_Item_Too_Early
(E
, N
)
24501 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
24506 -- For incomplete/private type, set flag on full view
24508 if Is_Incomplete_Or_Private_Type
(E
) then
24509 if No
(Full_View
(Base_Type
(E
))) then
24511 ("argument of pragma% cannot be an incomplete type", Arg1
);
24513 Set_Suppress_Initialization
(Full_View
(E
));
24516 -- For first subtype, set flag on base type
24518 elsif Is_First_Subtype
(E
) then
24519 Set_Suppress_Initialization
(Base_Type
(E
));
24521 -- For other than first subtype, set flag on subtype or variable
24524 Set_Suppress_Initialization
(E
);
24532 -- pragma System_Name (DIRECT_NAME);
24534 -- Syntax check: one argument, which must be the identifier GNAT or
24535 -- the identifier GCC, no other identifiers are acceptable.
24537 when Pragma_System_Name
=>
24539 Check_No_Identifiers
;
24540 Check_Arg_Count
(1);
24541 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
24543 -----------------------------
24544 -- Task_Dispatching_Policy --
24545 -----------------------------
24547 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24549 when Pragma_Task_Dispatching_Policy
=> declare
24553 Check_Ada_83_Warning
;
24554 Check_Arg_Count
(1);
24555 Check_No_Identifiers
;
24556 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
24557 Check_Valid_Configuration_Pragma
;
24558 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24559 DP
:= Fold_Upper
(Name_Buffer
(1));
24561 if Task_Dispatching_Policy
/= ' '
24562 and then Task_Dispatching_Policy
/= DP
24564 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
24566 ("task dispatching policy incompatible with policy#");
24568 -- Set new policy, but always preserve System_Location since we
24569 -- like the error message with the run time name.
24572 Task_Dispatching_Policy
:= DP
;
24574 if Task_Dispatching_Policy_Sloc
/= System_Location
then
24575 Task_Dispatching_Policy_Sloc
:= Loc
;
24584 -- pragma Task_Info (EXPRESSION);
24586 when Pragma_Task_Info
=> Task_Info
: declare
24587 P
: constant Node_Id
:= Parent
(N
);
24593 if Warn_On_Obsolescent_Feature
then
24595 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24596 & "instead?j?", N
);
24599 if Nkind
(P
) /= N_Task_Definition
then
24600 Error_Pragma
("pragma% must appear in task definition");
24603 Check_No_Identifiers
;
24604 Check_Arg_Count
(1);
24606 Analyze_And_Resolve
24607 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
24609 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
24613 Ent
:= Defining_Identifier
(Parent
(P
));
24615 -- Check duplicate pragma before we chain the pragma in the Rep
24616 -- Item chain of Ent.
24619 (Ent
, Name_Task_Info
, Check_Parents
=> False)
24621 Error_Pragma
("duplicate pragma% not allowed");
24624 Record_Rep_Item
(Ent
, N
);
24631 -- pragma Task_Name (string_EXPRESSION);
24633 when Pragma_Task_Name
=> Task_Name
: declare
24634 P
: constant Node_Id
:= Parent
(N
);
24639 Check_No_Identifiers
;
24640 Check_Arg_Count
(1);
24642 Arg
:= Get_Pragma_Arg
(Arg1
);
24644 -- The expression is used in the call to Create_Task, and must be
24645 -- expanded there, not in the context of the current spec. It must
24646 -- however be analyzed to capture global references, in case it
24647 -- appears in a generic context.
24649 Preanalyze_And_Resolve
(Arg
, Standard_String
);
24651 if Nkind
(P
) /= N_Task_Definition
then
24655 Ent
:= Defining_Identifier
(Parent
(P
));
24657 -- Check duplicate pragma before we chain the pragma in the Rep
24658 -- Item chain of Ent.
24661 (Ent
, Name_Task_Name
, Check_Parents
=> False)
24663 Error_Pragma
("duplicate pragma% not allowed");
24666 Record_Rep_Item
(Ent
, N
);
24673 -- pragma Task_Storage (
24674 -- [Task_Type =>] LOCAL_NAME,
24675 -- [Top_Guard =>] static_integer_EXPRESSION);
24677 when Pragma_Task_Storage
=> Task_Storage
: declare
24678 Args
: Args_List
(1 .. 2);
24679 Names
: constant Name_List
(1 .. 2) := (
24683 Task_Type
: Node_Id
renames Args
(1);
24684 Top_Guard
: Node_Id
renames Args
(2);
24690 Gather_Associations
(Names
, Args
);
24692 if No
(Task_Type
) then
24694 ("missing task_type argument for pragma%");
24697 Check_Arg_Is_Local_Name
(Task_Type
);
24699 Ent
:= Entity
(Task_Type
);
24701 if not Is_Task_Type
(Ent
) then
24703 ("argument for pragma% must be task type", Task_Type
);
24706 if No
(Top_Guard
) then
24708 ("pragma% takes two arguments", Task_Type
);
24710 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
24713 Check_First_Subtype
(Task_Type
);
24715 if Rep_Item_Too_Late
(Ent
, N
) then
24724 -- pragma Test_Case
24725 -- ([Name =>] Static_String_EXPRESSION
24726 -- ,[Mode =>] MODE_TYPE
24727 -- [, Requires => Boolean_EXPRESSION]
24728 -- [, Ensures => Boolean_EXPRESSION]);
24730 -- MODE_TYPE ::= Nominal | Robustness
24732 -- Characteristics:
24734 -- * Analysis - The annotation undergoes initial checks to verify
24735 -- the legal placement and context. Secondary checks preanalyze the
24738 -- Analyze_Test_Case_In_Decl_Part
24740 -- * Expansion - None.
24742 -- * Template - The annotation utilizes the generic template of the
24743 -- related subprogram when it is:
24745 -- aspect on subprogram declaration
24747 -- The annotation must prepare its own template when it is:
24749 -- pragma on subprogram declaration
24751 -- * Globals - Capture of global references must occur after full
24754 -- * Instance - The annotation is instantiated automatically when
24755 -- the related generic subprogram is instantiated except for the
24756 -- "pragma on subprogram declaration" case. In that scenario the
24757 -- annotation must instantiate itself.
24759 when Pragma_Test_Case
=> Test_Case
: declare
24760 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
24761 -- Ensure that the contract of subprogram Subp_Id does not contain
24762 -- another Test_Case pragma with the same Name as the current one.
24764 -------------------------
24765 -- Check_Distinct_Name --
24766 -------------------------
24768 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
24769 Items
: constant Node_Id
:= Contract
(Subp_Id
);
24770 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
24774 -- Inspect all Test_Case pragma of the related subprogram
24775 -- looking for one with a duplicate "Name" argument.
24777 if Present
(Items
) then
24778 Prag
:= Contract_Test_Cases
(Items
);
24779 while Present
(Prag
) loop
24780 if Pragma_Name
(Prag
) = Name_Test_Case
24782 and then String_Equal
24783 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
24785 Error_Msg_Sloc
:= Sloc
(Prag
);
24786 Error_Pragma
("name for pragma % is already used #");
24789 Prag
:= Next_Pragma
(Prag
);
24792 end Check_Distinct_Name
;
24796 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
24799 Subp_Decl
: Node_Id
;
24800 Subp_Id
: Entity_Id
;
24802 -- Start of processing for Test_Case
24806 Check_At_Least_N_Arguments
(2);
24807 Check_At_Most_N_Arguments
(4);
24809 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
24813 Check_Optional_Identifier
(Arg1
, Name_Name
);
24814 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24818 Check_Optional_Identifier
(Arg2
, Name_Mode
);
24819 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
24821 -- Arguments "Requires" and "Ensures"
24823 if Present
(Arg3
) then
24824 if Present
(Arg4
) then
24825 Check_Identifier
(Arg3
, Name_Requires
);
24826 Check_Identifier
(Arg4
, Name_Ensures
);
24828 Check_Identifier_Is_One_Of
24829 (Arg3
, Name_Requires
, Name_Ensures
);
24833 -- Pragma Test_Case must be associated with a subprogram declared
24834 -- in a library-level package. First determine whether the current
24835 -- compilation unit is a legal context.
24837 if Nkind
(Pack_Decl
) in N_Package_Declaration
24838 | N_Generic_Package_Declaration
24842 -- Otherwise the placement is illegal
24846 ("pragma % must be specified within a package declaration");
24849 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
24851 -- Find the enclosing context
24853 Context
:= Parent
(Subp_Decl
);
24855 if Present
(Context
) then
24856 Context
:= Parent
(Context
);
24859 -- Verify the placement of the pragma
24861 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
24863 ("pragma % cannot be applied to abstract subprogram");
24865 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
24866 Error_Pragma
("pragma % cannot be applied to entry");
24868 -- The context is a [generic] subprogram declared at the top level
24869 -- of the [generic] package unit.
24871 elsif Nkind
(Subp_Decl
) in N_Generic_Subprogram_Declaration
24872 | N_Subprogram_Declaration
24873 and then Present
(Context
)
24874 and then Nkind
(Context
) in N_Generic_Package_Declaration
24875 | N_Package_Declaration
24879 -- Otherwise the placement is illegal
24883 ("pragma % must be applied to a library-level subprogram "
24887 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24889 -- A pragma that applies to a Ghost entity becomes Ghost for the
24890 -- purposes of legality checks and removal of ignored Ghost code.
24892 Mark_Ghost_Pragma
(N
, Subp_Id
);
24894 -- Chain the pragma on the contract for further processing by
24895 -- Analyze_Test_Case_In_Decl_Part.
24897 Add_Contract_Item
(N
, Subp_Id
);
24899 -- Preanalyze the original aspect argument "Name" for a generic
24900 -- subprogram to properly capture global references.
24902 if Is_Generic_Subprogram
(Subp_Id
) then
24903 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
24905 if Present
(Asp_Arg
) then
24907 -- The argument appears with an identifier in association
24910 if Nkind
(Asp_Arg
) = N_Component_Association
then
24911 Asp_Arg
:= Expression
(Asp_Arg
);
24914 Check_Expr_Is_OK_Static_Expression
24915 (Asp_Arg
, Standard_String
);
24919 -- Ensure that the all Test_Case pragmas of the related subprogram
24920 -- have distinct names.
24922 Check_Distinct_Name
(Subp_Id
);
24924 -- Fully analyze the pragma when it appears inside an entry
24925 -- or subprogram body because it cannot benefit from forward
24928 if Nkind
(Subp_Decl
) in N_Entry_Body
24929 | N_Subprogram_Body
24930 | N_Subprogram_Body_Stub
24932 -- The legality checks of pragma Test_Case are affected by the
24933 -- SPARK mode in effect and the volatility of the context.
24934 -- Analyze all pragmas in a specific order.
24936 Analyze_If_Present
(Pragma_SPARK_Mode
);
24937 Analyze_If_Present
(Pragma_Volatile_Function
);
24938 Analyze_Test_Case_In_Decl_Part
(N
);
24942 --------------------------
24943 -- Thread_Local_Storage --
24944 --------------------------
24946 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24948 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
24954 Check_Arg_Count
(1);
24955 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24956 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24958 Id
:= Get_Pragma_Arg
(Arg1
);
24960 if not Is_Entity_Name
(Id
)
24961 or else Ekind
(Entity
(Id
)) /= E_Variable
24963 Error_Pragma_Arg
("local variable name required", Arg1
);
24968 -- A pragma that applies to a Ghost entity becomes Ghost for the
24969 -- purposes of legality checks and removal of ignored Ghost code.
24971 Mark_Ghost_Pragma
(N
, E
);
24973 if Rep_Item_Too_Early
(E
, N
)
24975 Rep_Item_Too_Late
(E
, N
)
24980 Set_Has_Pragma_Thread_Local_Storage
(E
);
24981 Set_Has_Gigi_Rep_Item
(E
);
24982 end Thread_Local_Storage
;
24988 -- pragma Time_Slice (static_duration_EXPRESSION);
24990 when Pragma_Time_Slice
=> Time_Slice
: declare
24996 Check_Arg_Count
(1);
24997 Check_No_Identifiers
;
24998 Check_In_Main_Program
;
24999 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
25001 if not Error_Posted
(Arg1
) then
25003 while Present
(Nod
) loop
25004 if Nkind
(Nod
) = N_Pragma
25005 and then Pragma_Name
(Nod
) = Name_Time_Slice
25007 Error_Msg_Name_1
:= Pname
;
25008 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
25015 -- Process only if in main unit
25017 if Get_Source_Unit
(Loc
) = Main_Unit
then
25018 Opt
.Time_Slice_Set
:= True;
25019 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
25021 if Val
<= Ureal_0
then
25022 Opt
.Time_Slice_Value
:= 0;
25024 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
25025 Opt
.Time_Slice_Value
:= 1_000_000_000
;
25028 Opt
.Time_Slice_Value
:=
25029 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
25038 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
25040 -- TITLING_OPTION ::=
25041 -- [Title =>] STRING_LITERAL
25042 -- | [Subtitle =>] STRING_LITERAL
25044 when Pragma_Title
=> Title
: declare
25045 Args
: Args_List
(1 .. 2);
25046 Names
: constant Name_List
(1 .. 2) := (
25052 Gather_Associations
(Names
, Args
);
25055 for J
in 1 .. 2 loop
25056 if Present
(Args
(J
)) then
25057 Check_Arg_Is_OK_Static_Expression
25058 (Args
(J
), Standard_String
);
25063 ----------------------------
25064 -- Type_Invariant[_Class] --
25065 ----------------------------
25067 -- pragma Type_Invariant[_Class]
25068 -- ([Entity =>] type_LOCAL_NAME,
25069 -- [Check =>] EXPRESSION);
25071 when Pragma_Type_Invariant
25072 | Pragma_Type_Invariant_Class
25074 Type_Invariant
: declare
25075 I_Pragma
: Node_Id
;
25078 Check_Arg_Count
(2);
25080 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
25081 -- setting Class_Present for the Type_Invariant_Class case.
25083 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
25084 I_Pragma
:= New_Copy
(N
);
25085 Set_Pragma_Identifier
25086 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
25087 Rewrite
(N
, I_Pragma
);
25088 Set_Analyzed
(N
, False);
25090 end Type_Invariant
;
25092 ---------------------
25093 -- Unchecked_Union --
25094 ---------------------
25096 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
25098 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
25099 Assoc
: constant Node_Id
:= Arg1
;
25100 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
25110 Check_No_Identifiers
;
25111 Check_Arg_Count
(1);
25112 Check_Arg_Is_Local_Name
(Arg1
);
25114 Find_Type
(Type_Id
);
25116 Typ
:= Entity
(Type_Id
);
25118 -- A pragma that applies to a Ghost entity becomes Ghost for the
25119 -- purposes of legality checks and removal of ignored Ghost code.
25121 Mark_Ghost_Pragma
(N
, Typ
);
25124 or else Rep_Item_Too_Early
(Typ
, N
)
25128 Typ
:= Underlying_Type
(Typ
);
25131 if Rep_Item_Too_Late
(Typ
, N
) then
25135 Check_First_Subtype
(Arg1
);
25137 -- Note remaining cases are references to a type in the current
25138 -- declarative part. If we find an error, we post the error on
25139 -- the relevant type declaration at an appropriate point.
25141 if not Is_Record_Type
(Typ
) then
25142 Error_Msg_N
("unchecked union must be record type", Typ
);
25145 elsif Is_Tagged_Type
(Typ
) then
25146 Error_Msg_N
("unchecked union must not be tagged", Typ
);
25149 elsif not Has_Discriminants
(Typ
) then
25151 ("unchecked union must have one discriminant", Typ
);
25154 -- Note: in previous versions of GNAT we used to check for limited
25155 -- types and give an error, but in fact the standard does allow
25156 -- Unchecked_Union on limited types, so this check was removed.
25158 -- Similarly, GNAT used to require that all discriminants have
25159 -- default values, but this is not mandated by the RM.
25161 -- Proceed with basic error checks completed
25164 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
25165 Clist
:= Component_List
(Tdef
);
25167 -- Check presence of component list and variant part
25169 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
25171 ("unchecked union must have variant part", Tdef
);
25175 -- Check components
25177 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
25178 while Present
(Comp
) loop
25179 Check_Component
(Comp
, Typ
);
25180 Next_Non_Pragma
(Comp
);
25183 -- Check variant part
25185 Vpart
:= Variant_Part
(Clist
);
25187 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
25188 while Present
(Variant
) loop
25189 Check_Variant
(Variant
, Typ
);
25190 Next_Non_Pragma
(Variant
);
25194 Set_Is_Unchecked_Union
(Typ
);
25195 Set_Convention
(Typ
, Convention_C
);
25196 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
25197 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
25198 end Unchecked_Union
;
25200 ----------------------------
25201 -- Unevaluated_Use_Of_Old --
25202 ----------------------------
25204 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
25206 when Pragma_Unevaluated_Use_Of_Old
=>
25208 Check_Arg_Count
(1);
25209 Check_No_Identifiers
;
25210 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
25212 -- Suppress/Unsuppress can appear as a configuration pragma, or in
25213 -- a declarative part or a package spec.
25215 if not Is_Configuration_Pragma
then
25216 Check_Is_In_Decl_Part_Or_Package_Spec
;
25219 -- Store proper setting of Uneval_Old
25221 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
25222 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
25224 ------------------------
25225 -- Unimplemented_Unit --
25226 ------------------------
25228 -- pragma Unimplemented_Unit;
25230 -- Note: this only gives an error if we are generating code, or if
25231 -- we are in a generic library unit (where the pragma appears in the
25232 -- body, not in the spec).
25234 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
25235 Cunitent
: constant Entity_Id
:=
25236 Cunit_Entity
(Get_Source_Unit
(Loc
));
25240 Check_Arg_Count
(0);
25242 if Operating_Mode
= Generate_Code
25243 or else Is_Generic_Unit
(Cunitent
)
25245 Get_Name_String
(Chars
(Cunitent
));
25246 Set_Casing
(Mixed_Case
);
25247 Write_Str
(Name_Buffer
(1 .. Name_Len
));
25248 Write_Str
(" is not supported in this configuration");
25250 raise Unrecoverable_Error
;
25252 end Unimplemented_Unit
;
25254 ------------------------
25255 -- Universal_Aliasing --
25256 ------------------------
25258 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
25260 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
25266 Check_Arg_Count
(1);
25267 Check_Optional_Identifier
(Arg2
, Name_Entity
);
25268 Check_Arg_Is_Local_Name
(Arg1
);
25269 E_Id
:= Get_Pragma_Arg
(Arg1
);
25271 if Etype
(E_Id
) = Any_Type
then
25275 E
:= Entity
(E_Id
);
25277 if not Is_Type
(E
) then
25278 Error_Pragma_Arg
("pragma% requires type", Arg1
);
25281 -- A pragma that applies to a Ghost entity becomes Ghost for the
25282 -- purposes of legality checks and removal of ignored Ghost code.
25284 Mark_Ghost_Pragma
(N
, E
);
25285 Set_Universal_Aliasing
(Base_Type
(E
));
25286 Record_Rep_Item
(E
, N
);
25287 end Universal_Alias
;
25293 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
25295 when Pragma_Unmodified
=>
25296 Analyze_Unmodified_Or_Unused
;
25302 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
25304 -- or when used in a context clause:
25306 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
25308 when Pragma_Unreferenced
=>
25309 Analyze_Unreferenced_Or_Unused
;
25311 --------------------------
25312 -- Unreferenced_Objects --
25313 --------------------------
25315 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
25317 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
25319 Arg_Expr
: Node_Id
;
25320 Arg_Id
: Entity_Id
;
25322 Ghost_Error_Posted
: Boolean := False;
25323 -- Flag set when an error concerning the illegal mix of Ghost and
25324 -- non-Ghost types is emitted.
25326 Ghost_Id
: Entity_Id
:= Empty
;
25327 -- The entity of the first Ghost type encountered while processing
25328 -- the arguments of the pragma.
25332 Check_At_Least_N_Arguments
(1);
25335 while Present
(Arg
) loop
25336 Check_No_Identifier
(Arg
);
25337 Check_Arg_Is_Local_Name
(Arg
);
25338 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
25340 if Is_Entity_Name
(Arg_Expr
) then
25341 Arg_Id
:= Entity
(Arg_Expr
);
25343 if Is_Type
(Arg_Id
) then
25344 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
25346 -- A pragma that applies to a Ghost entity becomes Ghost
25347 -- for the purposes of legality checks and removal of
25348 -- ignored Ghost code.
25350 Mark_Ghost_Pragma
(N
, Arg_Id
);
25352 -- Capture the entity of the first Ghost type being
25353 -- processed for error detection purposes.
25355 if Is_Ghost_Entity
(Arg_Id
) then
25356 if No
(Ghost_Id
) then
25357 Ghost_Id
:= Arg_Id
;
25360 -- Otherwise the type is non-Ghost. It is illegal to mix
25361 -- references to Ghost and non-Ghost entities
25364 elsif Present
(Ghost_Id
)
25365 and then not Ghost_Error_Posted
25367 Ghost_Error_Posted
:= True;
25369 Error_Msg_Name_1
:= Pname
;
25371 ("pragma % cannot mention ghost and non-ghost types",
25374 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
25375 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
25377 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
25378 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
25382 ("argument for pragma% must be type or subtype", Arg
);
25386 ("argument for pragma% must be type or subtype", Arg
);
25391 end Unreferenced_Objects
;
25393 ------------------------------
25394 -- Unreserve_All_Interrupts --
25395 ------------------------------
25397 -- pragma Unreserve_All_Interrupts;
25399 when Pragma_Unreserve_All_Interrupts
=>
25401 Check_Arg_Count
(0);
25403 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
25404 Unreserve_All_Interrupts
:= True;
25411 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25413 when Pragma_Unsuppress
=>
25415 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
25421 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25423 when Pragma_Unused
=>
25424 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
25425 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
25427 -------------------
25428 -- Use_VADS_Size --
25429 -------------------
25431 -- pragma Use_VADS_Size;
25433 when Pragma_Use_VADS_Size
=>
25435 Check_Arg_Count
(0);
25436 Check_Valid_Configuration_Pragma
;
25437 Use_VADS_Size
:= True;
25439 ---------------------
25440 -- Validity_Checks --
25441 ---------------------
25443 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25445 when Pragma_Validity_Checks
=> Validity_Checks
: declare
25446 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25452 Check_Arg_Count
(1);
25453 Check_No_Identifiers
;
25455 -- Pragma always active unless in CodePeer or GNATprove modes,
25456 -- which use a fixed configuration of validity checks.
25458 if not (CodePeer_Mode
or GNATprove_Mode
) then
25459 if Nkind
(A
) = N_String_Literal
then
25463 Slen
: constant Natural := Natural (String_Length
(S
));
25464 Options
: String (1 .. Slen
);
25468 -- Couldn't we use a for loop here over Options'Range???
25472 C
:= Get_String_Char
(S
, Pos
(J
));
25474 -- This is a weird test, it skips setting validity
25475 -- checks entirely if any element of S is out of
25476 -- range of Character, what is that about ???
25478 exit when not In_Character_Range
(C
);
25479 Options
(J
) := Get_Character
(C
);
25482 Set_Validity_Check_Options
(Options
);
25490 elsif Nkind
(A
) = N_Identifier
then
25491 if Chars
(A
) = Name_All_Checks
then
25492 Set_Validity_Check_Options
("a");
25493 elsif Chars
(A
) = Name_On
then
25494 Validity_Checks_On
:= True;
25495 elsif Chars
(A
) = Name_Off
then
25496 Validity_Checks_On
:= False;
25500 end Validity_Checks
;
25506 -- pragma Volatile (LOCAL_NAME);
25508 when Pragma_Volatile
=>
25509 Process_Atomic_Independent_Shared_Volatile
;
25511 -------------------------
25512 -- Volatile_Components --
25513 -------------------------
25515 -- pragma Volatile_Components (array_LOCAL_NAME);
25517 -- Volatile is handled by the same circuit as Atomic_Components
25519 --------------------------
25520 -- Volatile_Full_Access --
25521 --------------------------
25523 -- pragma Volatile_Full_Access (LOCAL_NAME);
25525 when Pragma_Volatile_Full_Access
=>
25527 Process_Atomic_Independent_Shared_Volatile
;
25529 -----------------------
25530 -- Volatile_Function --
25531 -----------------------
25533 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25535 when Pragma_Volatile_Function
=> Volatile_Function
: declare
25536 Over_Id
: Entity_Id
;
25537 Spec_Id
: Entity_Id
;
25538 Subp_Decl
: Node_Id
;
25542 Check_No_Identifiers
;
25543 Check_At_Most_N_Arguments
(1);
25546 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25548 -- Generic subprogram
25550 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25553 -- Body acts as spec
25555 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25556 and then No
(Corresponding_Spec
(Subp_Decl
))
25560 -- Body stub acts as spec
25562 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25563 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25569 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25576 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25578 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
25582 -- A pragma that applies to a Ghost entity becomes Ghost for the
25583 -- purposes of legality checks and removal of ignored Ghost code.
25585 Mark_Ghost_Pragma
(N
, Spec_Id
);
25587 -- Chain the pragma on the contract for completeness
25589 Add_Contract_Item
(N
, Spec_Id
);
25591 -- The legality checks of pragma Volatile_Function are affected by
25592 -- the SPARK mode in effect. Analyze all pragmas in a specific
25595 Analyze_If_Present
(Pragma_SPARK_Mode
);
25597 -- A volatile function cannot override a non-volatile function
25598 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25599 -- in New_Overloaded_Entity, however at that point the pragma has
25600 -- not been processed yet.
25602 Over_Id
:= Overridden_Operation
(Spec_Id
);
25604 if Present
(Over_Id
)
25605 and then not Is_Volatile_Function
(Over_Id
)
25608 ("incompatible volatile function values in effect", Spec_Id
);
25610 Error_Msg_Sloc
:= Sloc
(Over_Id
);
25612 ("\& declared # with Volatile_Function value False",
25615 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
25617 ("\overridden # with Volatile_Function value True",
25621 -- Analyze the Boolean expression (if any)
25623 if Present
(Arg1
) then
25624 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
25626 end Volatile_Function
;
25628 ----------------------
25629 -- Warning_As_Error --
25630 ----------------------
25632 -- pragma Warning_As_Error (static_string_EXPRESSION);
25634 when Pragma_Warning_As_Error
=>
25636 Check_Arg_Count
(1);
25637 Check_No_Identifiers
;
25638 Check_Valid_Configuration_Pragma
;
25640 if not Is_Static_String_Expression
(Arg1
) then
25642 ("argument of pragma% must be static string expression",
25645 -- OK static string expression
25648 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
25649 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
25650 new String'(Acquire_Warning_Match_String
25651 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25658 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25660 -- DETAILS ::= On | Off
25661 -- DETAILS ::= On | Off, local_NAME
25662 -- DETAILS ::= static_string_EXPRESSION
25663 -- DETAILS ::= On | Off, static_string_EXPRESSION
25665 -- TOOL_NAME ::= GNAT | GNATprove
25667 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25669 -- Note: If the first argument matches an allowed tool name, it is
25670 -- always considered to be a tool name, even if there is a string
25671 -- variable of that name.
25673 -- Note if the second argument of DETAILS is a local_NAME then the
25674 -- second form is always understood. If the intention is to use
25675 -- the fourth form, then you can write NAME & "" to force the
25676 -- intepretation as a static_string_EXPRESSION.
25678 when Pragma_Warnings => Warnings : declare
25679 Reason : String_Id;
25683 Check_At_Least_N_Arguments (1);
25685 -- See if last argument is labeled Reason. If so, make sure we
25686 -- have a string literal or a concatenation of string literals,
25687 -- and acquire the REASON string. Then remove the REASON argument
25688 -- by decreasing Num_Args by one; Remaining processing looks only
25689 -- at first Num_Args arguments).
25692 Last_Arg : constant Node_Id :=
25693 Last (Pragma_Argument_Associations (N));
25696 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25697 and then Chars (Last_Arg) = Name_Reason
25700 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25701 Reason := End_String;
25702 Arg_Count := Arg_Count - 1;
25704 -- No REASON string, set null string as reason
25707 Reason := Null_String_Id;
25711 -- Now proceed with REASON taken care of and eliminated
25713 Check_No_Identifiers;
25715 -- If debug flag -gnatd.i is set, pragma is ignored
25717 if Debug_Flag_Dot_I then
25721 -- Process various forms of the pragma
25724 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25725 Shifted_Args : List_Id;
25728 -- See if first argument is a tool name, currently either
25729 -- GNAT or GNATprove. If so, either ignore the pragma if the
25730 -- tool used does not match, or continue as if no tool name
25731 -- was given otherwise, by shifting the arguments.
25733 if Nkind (Argx) = N_Identifier
25734 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25736 if Chars (Argx) = Name_Gnat then
25737 if CodePeer_Mode or GNATprove_Mode then
25738 Rewrite (N, Make_Null_Statement (Loc));
25743 elsif Chars (Argx) = Name_Gnatprove then
25744 if not GNATprove_Mode then
25745 Rewrite (N, Make_Null_Statement (Loc));
25750 raise Program_Error;
25753 -- At this point, the pragma Warnings applies to the tool,
25754 -- so continue with shifted arguments.
25756 Arg_Count := Arg_Count - 1;
25758 if Arg_Count = 1 then
25759 Shifted_Args := New_List (New_Copy (Arg2));
25760 elsif Arg_Count = 2 then
25761 Shifted_Args := New_List (New_Copy (Arg2),
25763 elsif Arg_Count = 3 then
25764 Shifted_Args := New_List (New_Copy (Arg2),
25768 raise Program_Error;
25773 Chars => Name_Warnings,
25774 Pragma_Argument_Associations => Shifted_Args));
25779 -- One argument case
25781 if Arg_Count = 1 then
25783 -- On/Off one argument case was processed by parser
25785 if Nkind (Argx) = N_Identifier
25786 and then Chars (Argx) in Name_On | Name_Off
25790 -- One argument case must be ON/OFF or static string expr
25792 elsif not Is_Static_String_Expression (Arg1) then
25794 ("argument of pragma% must be On/Off or static string "
25795 & "expression", Arg1);
25797 -- Use of pragma Warnings to set warning switches is
25798 -- ignored in GNATprove mode, as these switches apply to
25799 -- the compiler only.
25801 elsif GNATprove_Mode then
25804 -- One argument string expression case
25808 Lit : constant Node_Id := Expr_Value_S (Argx);
25809 Str : constant String_Id := Strval (Lit);
25810 Len : constant Nat := String_Length (Str);
25818 while J <= Len loop
25819 C := Get_String_Char (Str, J);
25820 OK := In_Character_Range (C);
25823 Chr := Get_Character (C);
25825 -- Dash case: only -Wxxx is accepted
25832 C := Get_String_Char (Str, J);
25833 Chr := Get_Character (C);
25834 exit when Chr = 'W
';
25839 elsif J < Len and then Chr = '.' then
25841 C := Get_String_Char (Str, J);
25842 Chr := Get_Character (C);
25844 if not Set_Warning_Switch ('.', Chr) then
25846 ("invalid warning switch character "
25847 & '.' & Chr, Arg1);
25853 OK := Set_Warning_Switch (Plain, Chr);
25858 ("invalid warning switch character " & Chr,
25864 ("invalid wide character in warning switch ",
25873 -- Two or more arguments (must be two)
25876 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25877 Check_Arg_Count (2);
25885 E_Id := Get_Pragma_Arg (Arg2);
25888 -- In the expansion of an inlined body, a reference to
25889 -- the formal may be wrapped in a conversion if the
25890 -- actual is a conversion. Retrieve the real entity name.
25892 if (In_Instance_Body or In_Inlined_Body)
25893 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25895 E_Id := Expression (E_Id);
25898 -- Entity name case
25900 if Is_Entity_Name (E_Id) then
25901 E := Entity (E_Id);
25908 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25911 -- Suppress elaboration warnings if the entity
25912 -- denotes an elaboration target.
25914 if Is_Elaboration_Target (E) then
25915 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25918 -- For OFF case, make entry in warnings off
25919 -- pragma table for later processing. But we do
25920 -- not do that within an instance, since these
25921 -- warnings are about what is needed in the
25922 -- template, not an instance of it.
25924 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25925 and then Warn_On_Warnings_Off
25926 and then not In_Instance
25928 Warnings_Off_Pragmas.Append ((N, E, Reason));
25931 if Is_Enumeration_Type (E) then
25935 Lit := First_Literal (E);
25936 while Present (Lit) loop
25937 Set_Warnings_Off (Lit);
25938 Next_Literal (Lit);
25943 exit when No (Homonym (E));
25948 -- Error if not entity or static string expression case
25950 elsif not Is_Static_String_Expression (Arg2) then
25952 ("second argument of pragma% must be entity name "
25953 & "or static string expression", Arg2);
25955 -- Static string expression case
25958 -- Note on configuration pragma case: If this is a
25959 -- configuration pragma, then for an OFF pragma, we
25960 -- just set Config True in the call, which is all
25961 -- that needs to be done. For the case of ON, this
25962 -- is normally an error, unless it is canceling the
25963 -- effect of a previous OFF pragma in the same file.
25964 -- In any other case, an error will be signalled (ON
25965 -- with no matching OFF).
25967 -- Note: We set Used if we are inside a generic to
25968 -- disable the test that the non-config case actually
25969 -- cancels a warning. That's because we can't be sure
25970 -- there isn't an instantiation in some other unit
25971 -- where a warning is suppressed.
25973 -- We could do a little better here by checking if the
25974 -- generic unit we are inside is public, but for now
25975 -- we don't bother with that refinement.
25978 Message : constant String :=
25979 Acquire_Warning_Match_String
25980 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25982 if Chars (Argx) = Name_Off then
25983 Set_Specific_Warning_Off
25984 (Loc, Message, Reason,
25985 Config => Is_Configuration_Pragma,
25986 Used => Inside_A_Generic or else In_Instance);
25988 elsif Chars (Argx) = Name_On then
25989 Set_Specific_Warning_On (Loc, Message, Err);
25993 ("??pragma Warnings On with no matching "
25994 & "Warnings Off", N);
26004 -------------------
26005 -- Weak_External --
26006 -------------------
26008 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
26010 when Pragma_Weak_External => Weak_External : declare
26015 Check_Arg_Count (1);
26016 Check_Optional_Identifier (Arg1, Name_Entity);
26017 Check_Arg_Is_Library_Level_Local_Name (Arg1);
26018 Ent := Entity (Get_Pragma_Arg (Arg1));
26020 if Rep_Item_Too_Early (Ent, N) then
26023 Ent := Underlying_Type (Ent);
26026 -- The pragma applies to entities with addresses
26028 if Is_Type (Ent) then
26029 Error_Pragma ("pragma applies to objects and subprograms");
26032 -- The only processing required is to link this item on to the
26033 -- list of rep items for the given entity. This is accomplished
26034 -- by the call to Rep_Item_Too_Late (when no error is detected
26035 -- and False is returned).
26037 if Rep_Item_Too_Late (Ent, N) then
26040 Set_Has_Gigi_Rep_Item (Ent);
26044 -----------------------------
26045 -- Wide_Character_Encoding --
26046 -----------------------------
26048 -- pragma Wide_Character_Encoding (IDENTIFIER);
26050 when Pragma_Wide_Character_Encoding =>
26053 -- Nothing to do, handled in parser. Note that we do not enforce
26054 -- configuration pragma placement, this pragma can appear at any
26055 -- place in the source, allowing mixed encodings within a single
26060 --------------------
26061 -- Unknown_Pragma --
26062 --------------------
26064 -- Should be impossible, since the case of an unknown pragma is
26065 -- separately processed before the case statement is entered.
26067 when Unknown_Pragma =>
26068 raise Program_Error;
26071 -- AI05-0144: detect dangerous order dependence. Disabled for now,
26072 -- until AI is formally approved.
26074 -- Check_Order_Dependence;
26077 when Pragma_Exit => null;
26078 end Analyze_Pragma;
26080 ---------------------------------------------
26081 -- Analyze_Pre_Post_Condition_In_Decl_Part --
26082 ---------------------------------------------
26084 -- WARNING: This routine manages Ghost regions. Return statements must be
26085 -- replaced by gotos which jump to the end of the routine and restore the
26088 procedure Analyze_Pre_Post_Condition_In_Decl_Part
26090 Freeze_Id : Entity_Id := Empty)
26092 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26093 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26095 Disp_Typ : Entity_Id;
26096 -- The dispatching type of the subprogram subject to the pre- or
26099 function Check_References (Nod : Node_Id) return Traverse_Result;
26100 -- Check that expression Nod does not mention non-primitives of the
26101 -- type, global objects of the type, or other illegalities described
26102 -- and implied by AI12-0113.
26104 ----------------------
26105 -- Check_References --
26106 ----------------------
26108 function Check_References (Nod : Node_Id) return Traverse_Result is
26110 if Nkind (Nod) = N_Function_Call
26111 and then Is_Entity_Name (Name (Nod))
26114 Func : constant Entity_Id := Entity (Name (Nod));
26118 -- An operation of the type must be a primitive
26120 if No (Find_Dispatching_Type (Func)) then
26121 Form := First_Formal (Func);
26122 while Present (Form) loop
26123 if Etype (Form) = Disp_Typ then
26125 ("operation in class-wide condition must be "
26126 & "primitive of &", Nod, Disp_Typ);
26129 Next_Formal (Form);
26132 -- A return object of the type is illegal as well
26134 if Etype (Func) = Disp_Typ
26135 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
26138 ("operation in class-wide condition must be primitive "
26139 & "of &", Nod, Disp_Typ);
26144 elsif Is_Entity_Name (Nod)
26146 (Etype (Nod) = Disp_Typ
26147 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26148 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
26151 ("object in class-wide condition must be formal of type &",
26154 elsif Nkind (Nod) = N_Explicit_Dereference
26155 and then (Etype (Nod) = Disp_Typ
26156 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26157 and then (not Is_Entity_Name (Prefix (Nod))
26158 or else not Is_Formal (Entity (Prefix (Nod))))
26161 ("operation in class-wide condition must be primitive of &",
26166 end Check_References;
26168 procedure Check_Class_Wide_Condition is
26169 new Traverse_Proc (Check_References);
26173 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26175 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
26176 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
26177 -- Save the Ghost-related attributes to restore on exit
26180 Restore_Scope : Boolean := False;
26182 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
26185 -- Do not analyze the pragma multiple times
26187 if Is_Analyzed_Pragma (N) then
26191 -- Set the Ghost mode in effect from the pragma. Due to the delayed
26192 -- analysis of the pragma, the Ghost mode at point of declaration and
26193 -- point of analysis may not necessarily be the same. Use the mode in
26194 -- effect at the point of declaration.
26196 Set_Ghost_Mode (N);
26198 -- Ensure that the subprogram and its formals are visible when analyzing
26199 -- the expression of the pragma.
26201 if not In_Open_Scopes (Spec_Id) then
26202 Restore_Scope := True;
26203 Push_Scope (Spec_Id);
26205 if Is_Generic_Subprogram (Spec_Id) then
26206 Install_Generic_Formals (Spec_Id);
26208 Install_Formals (Spec_Id);
26212 Errors := Serious_Errors_Detected;
26213 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
26215 -- Emit a clarification message when the expression contains at least
26216 -- one undefined reference, possibly due to contract freezing.
26218 if Errors /= Serious_Errors_Detected
26219 and then Present (Freeze_Id)
26220 and then Has_Undefined_Reference (Expr)
26222 Contract_Freeze_Error (Spec_Id, Freeze_Id);
26225 if Class_Present (N) then
26227 -- Verify that a class-wide condition is legal, i.e. the operation is
26228 -- a primitive of a tagged type.
26230 if not Is_Dispatching_Operation (Spec_Id) then
26231 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
26233 if From_Aspect_Specification (N) then
26235 ("aspect % can only be specified for a primitive operation "
26236 & "of a tagged type", Corresponding_Aspect (N));
26238 -- The pragma is a source construct
26242 ("pragma % can only be specified for a primitive operation "
26243 & "of a tagged type", N);
26246 -- Remaining semantic checks require a full tree traversal
26249 Disp_Typ := Find_Dispatching_Type (Spec_Id);
26250 Check_Class_Wide_Condition (Expr);
26255 if Restore_Scope then
26259 -- Currently it is not possible to inline pre/postconditions on a
26260 -- subprogram subject to pragma Inline_Always.
26262 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26263 Set_Is_Analyzed_Pragma (N);
26265 -- If the subprogram is frozen then its class-wide pre- and post-
26266 -- conditions have been preanalyzed (see Merge_Class_Conditions);
26267 -- otherwise they must be preanalyzed now to ensure the correct
26268 -- visibility of their referenced entities. This scenario occurs
26269 -- when the subprogram is defined in a nested package (since the
26270 -- end of the package does not cause freezing).
26272 if Class_Present (N)
26273 and then Is_Dispatching_Operation (Spec_Id)
26274 and then not Is_Frozen (Spec_Id)
26276 Preanalyze_Class_Conditions (Spec_Id);
26279 Restore_Ghost_Region (Saved_GM, Saved_IGR);
26280 end Analyze_Pre_Post_Condition_In_Decl_Part;
26282 ------------------------------------------
26283 -- Analyze_Refined_Depends_In_Decl_Part --
26284 ------------------------------------------
26286 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
26287 procedure Check_Dependency_Clause
26288 (Spec_Id : Entity_Id;
26289 Dep_Clause : Node_Id;
26290 Dep_States : Elist_Id;
26291 Refinements : List_Id;
26292 Matched_Items : in out Elist_Id);
26293 -- Try to match a single dependency clause Dep_Clause against one or
26294 -- more refinement clauses found in list Refinements. Each successful
26295 -- match eliminates at least one refinement clause from Refinements.
26296 -- Spec_Id denotes the entity of the related subprogram. Dep_States
26297 -- denotes the entities of all abstract states which appear in pragma
26298 -- Depends. Matched_Items contains the entities of all successfully
26299 -- matched items found in pragma Depends.
26301 procedure Check_Output_States
26302 (Spec_Inputs : Elist_Id;
26303 Spec_Outputs : Elist_Id;
26304 Body_Inputs : Elist_Id;
26305 Body_Outputs : Elist_Id);
26306 -- Determine whether pragma Depends contains an output state with a
26307 -- visible refinement and if so, ensure that pragma Refined_Depends
26308 -- mentions all its constituents as outputs. Spec_Inputs and
26309 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
26310 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
26311 -- the inputs and outputs of the subprogram body synthesized from pragma
26312 -- Refined_Depends.
26314 function Collect_States (Clauses : List_Id) return Elist_Id;
26315 -- Given a normalized list of dependencies obtained from calling
26316 -- Normalize_Clauses, return a list containing the entities of all
26317 -- states appearing in dependencies. It helps in checking refinements
26318 -- involving a state and a corresponding constituent which is not a
26319 -- direct constituent of the state.
26321 procedure Normalize_Clauses (Clauses : List_Id);
26322 -- Given a list of dependence or refinement clauses Clauses, normalize
26323 -- each clause by creating multiple dependencies with exactly one input
26326 procedure Remove_Extra_Clauses
26327 (Clauses : List_Id;
26328 Matched_Items : Elist_Id);
26329 -- Given a list of refinement clauses Clauses, remove all clauses whose
26330 -- inputs and/or outputs have been previously matched. See the body for
26331 -- all special cases. Matched_Items contains the entities of all matched
26332 -- items found in pragma Depends.
26334 procedure Report_Extra_Clauses (Clauses : List_Id);
26335 -- Emit an error for each extra clause found in list Clauses
26337 -----------------------------
26338 -- Check_Dependency_Clause --
26339 -----------------------------
26341 procedure Check_Dependency_Clause
26342 (Spec_Id : Entity_Id;
26343 Dep_Clause : Node_Id;
26344 Dep_States : Elist_Id;
26345 Refinements : List_Id;
26346 Matched_Items : in out Elist_Id)
26348 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26349 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26351 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26352 -- Determine whether dependency item Dep_Item has been matched in a
26353 -- previous clause.
26355 function Is_In_Out_State_Clause return Boolean;
26356 -- Determine whether dependence clause Dep_Clause denotes an abstract
26357 -- state that depends on itself (State => State).
26359 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26360 -- Determine whether item Item denotes an abstract state with visible
26361 -- null refinement.
26363 procedure Match_Items
26364 (Dep_Item : Node_Id;
26365 Ref_Item : Node_Id;
26366 Matched : out Boolean);
26367 -- Try to match dependence item Dep_Item against refinement item
26368 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26369 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26370 -- the following conformance scenarios is in effect:
26371 -- 1) Both items denote null
26372 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26373 -- 3) Both items denote attribute 'Result
26374 -- 4) Both items denote the same object
26375 -- 5) Both items denote the same formal parameter
26376 -- 6) Both items denote the same current instance of a type
26377 -- 7) Both items denote the same discriminant
26378 -- 8) Dep_Item is an abstract state with visible null refinement
26379 -- and Ref_Item denotes null.
26380 -- 9) Dep_Item is an abstract state with visible null refinement
26381 -- and Ref_Item is Empty (special case).
26382 -- 10) Dep_Item is an abstract state with full or partial visible
26383 -- non-null refinement and Ref_Item denotes one of its
26385 -- 11) Dep_Item is an abstract state without a full visible
26386 -- refinement and Ref_Item denotes the same state.
26387 -- When scenario 10 is in effect, the entity of the abstract state
26388 -- denoted by Dep_Item is added to list Refined_States.
26390 procedure Record_Item
(Item_Id
: Entity_Id
);
26391 -- Store the entity of an item denoted by Item_Id in Matched_Items
26393 ------------------------
26394 -- Is_Already_Matched --
26395 ------------------------
26397 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
26398 Item_Id
: Entity_Id
:= Empty
;
26401 -- When the dependency item denotes attribute 'Result, check for
26402 -- the entity of the related subprogram.
26404 if Is_Attribute_Result
(Dep_Item
) then
26405 Item_Id
:= Spec_Id
;
26407 elsif Is_Entity_Name
(Dep_Item
) then
26408 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26412 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
26413 end Is_Already_Matched
;
26415 ----------------------------
26416 -- Is_In_Out_State_Clause --
26417 ----------------------------
26419 function Is_In_Out_State_Clause
return Boolean is
26420 Dep_Input_Id
: Entity_Id
;
26421 Dep_Output_Id
: Entity_Id
;
26424 -- Detect the following clause:
26427 if Is_Entity_Name
(Dep_Input
)
26428 and then Is_Entity_Name
(Dep_Output
)
26430 -- Handle abstract views generated for limited with clauses
26432 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
26433 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
26436 Ekind
(Dep_Input_Id
) = E_Abstract_State
26437 and then Dep_Input_Id
= Dep_Output_Id
;
26441 end Is_In_Out_State_Clause
;
26443 ---------------------------
26444 -- Is_Null_Refined_State --
26445 ---------------------------
26447 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
26448 Item_Id
: Entity_Id
;
26451 if Is_Entity_Name
(Item
) then
26453 -- Handle abstract views generated for limited with clauses
26455 Item_Id
:= Available_View
(Entity_Of
(Item
));
26458 Ekind
(Item_Id
) = E_Abstract_State
26459 and then Has_Null_Visible_Refinement
(Item_Id
);
26463 end Is_Null_Refined_State
;
26469 procedure Match_Items
26470 (Dep_Item
: Node_Id
;
26471 Ref_Item
: Node_Id
;
26472 Matched
: out Boolean)
26474 Dep_Item_Id
: Entity_Id
;
26475 Ref_Item_Id
: Entity_Id
;
26478 -- Assume that the two items do not match
26482 -- A null matches null or Empty (special case)
26484 if Nkind
(Dep_Item
) = N_Null
26485 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26489 -- Attribute 'Result matches attribute 'Result
26491 elsif Is_Attribute_Result
(Dep_Item
)
26492 and then Is_Attribute_Result
(Ref_Item
)
26494 -- Put the entity of the related function on the list of
26495 -- matched items because attribute 'Result does not carry
26496 -- an entity similar to states and constituents.
26498 Record_Item
(Spec_Id
);
26501 -- Abstract states, current instances of concurrent types,
26502 -- discriminants, formal parameters and objects.
26504 elsif Is_Entity_Name
(Dep_Item
) then
26506 -- Handle abstract views generated for limited with clauses
26508 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26510 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
26512 -- An abstract state with visible null refinement matches
26513 -- null or Empty (special case).
26515 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
26516 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26518 Record_Item
(Dep_Item_Id
);
26521 -- An abstract state with visible non-null refinement
26522 -- matches one of its constituents, or itself for an
26523 -- abstract state with partial visible refinement.
26525 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
26526 if Is_Entity_Name
(Ref_Item
) then
26527 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
26529 if Ekind
(Ref_Item_Id
) in
26530 E_Abstract_State | E_Constant | E_Variable
26531 and then Present
(Encapsulating_State
(Ref_Item_Id
))
26532 and then Find_Encapsulating_State
26533 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
26535 Record_Item
(Dep_Item_Id
);
26538 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
26539 and then Ref_Item_Id
= Dep_Item_Id
26541 Record_Item
(Dep_Item_Id
);
26546 -- An abstract state without a visible refinement matches
26549 elsif Is_Entity_Name
(Ref_Item
)
26550 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26552 Record_Item
(Dep_Item_Id
);
26556 -- A current instance of a concurrent type, discriminant,
26557 -- formal parameter or an object matches itself.
26559 elsif Is_Entity_Name
(Ref_Item
)
26560 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26562 Record_Item
(Dep_Item_Id
);
26572 procedure Record_Item
(Item_Id
: Entity_Id
) is
26574 if No
(Matched_Items
) then
26575 Matched_Items
:= New_Elmt_List
;
26578 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
26583 Clause_Matched
: Boolean := False;
26584 Dummy
: Boolean := False;
26585 Inputs_Match
: Boolean;
26586 Next_Ref_Clause
: Node_Id
;
26587 Outputs_Match
: Boolean;
26588 Ref_Clause
: Node_Id
;
26589 Ref_Input
: Node_Id
;
26590 Ref_Output
: Node_Id
;
26592 -- Start of processing for Check_Dependency_Clause
26595 -- Do not perform this check in an instance because it was already
26596 -- performed successfully in the generic template.
26598 if In_Instance
then
26602 -- Examine all refinement clauses and compare them against the
26603 -- dependence clause.
26605 Ref_Clause
:= First
(Refinements
);
26606 while Present
(Ref_Clause
) loop
26607 Next_Ref_Clause
:= Next
(Ref_Clause
);
26609 -- Obtain the attributes of the current refinement clause
26611 Ref_Input
:= Expression
(Ref_Clause
);
26612 Ref_Output
:= First
(Choices
(Ref_Clause
));
26614 -- The current refinement clause matches the dependence clause
26615 -- when both outputs match and both inputs match. See routine
26616 -- Match_Items for all possible conformance scenarios.
26618 -- Depends Dep_Output => Dep_Input
26622 -- Refined_Depends Ref_Output => Ref_Input
26625 (Dep_Item
=> Dep_Input
,
26626 Ref_Item
=> Ref_Input
,
26627 Matched
=> Inputs_Match
);
26630 (Dep_Item
=> Dep_Output
,
26631 Ref_Item
=> Ref_Output
,
26632 Matched
=> Outputs_Match
);
26634 -- An In_Out state clause may be matched against a refinement with
26635 -- a null input or null output as long as the non-null side of the
26636 -- relation contains a valid constituent of the In_Out_State.
26638 if Is_In_Out_State_Clause
then
26640 -- Depends => (State => State)
26641 -- Refined_Depends => (null => Constit) -- OK
26644 and then not Outputs_Match
26645 and then Nkind
(Ref_Output
) = N_Null
26647 Outputs_Match
:= True;
26650 -- Depends => (State => State)
26651 -- Refined_Depends => (Constit => null) -- OK
26653 if not Inputs_Match
26654 and then Outputs_Match
26655 and then Nkind
(Ref_Input
) = N_Null
26657 Inputs_Match
:= True;
26661 -- The current refinement clause is legally constructed following
26662 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26663 -- the pool of candidates. The search continues because a single
26664 -- dependence clause may have multiple matching refinements.
26666 if Inputs_Match
and Outputs_Match
then
26667 Clause_Matched
:= True;
26668 Remove
(Ref_Clause
);
26671 Ref_Clause
:= Next_Ref_Clause
;
26674 -- Depending on the order or composition of refinement clauses, an
26675 -- In_Out state clause may not be directly refinable.
26677 -- Refined_State => (State => (Constit_1, Constit_2))
26678 -- Depends => ((Output, State) => (Input, State))
26679 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26681 -- Matching normalized clause (State => State) fails because there is
26682 -- no direct refinement capable of satisfying this relation. Another
26683 -- similar case arises when clauses (Constit_1 => Input) and (Output
26684 -- => Constit_2) are matched first, leaving no candidates for clause
26685 -- (State => State). Both scenarios are legal as long as one of the
26686 -- previous clauses mentioned a valid constituent of State.
26688 if not Clause_Matched
26689 and then Is_In_Out_State_Clause
26690 and then Is_Already_Matched
(Dep_Input
)
26692 Clause_Matched
:= True;
26695 -- A clause where the input is an abstract state with visible null
26696 -- refinement or a 'Result attribute is implicitly matched when the
26697 -- output has already been matched in a previous clause.
26699 -- Refined_State => (State => null)
26700 -- Depends => (Output => State) -- implicitly OK
26701 -- Refined_Depends => (Output => ...)
26702 -- Depends => (...'Result => State) -- implicitly OK
26703 -- Refined_Depends => (...'Result => ...)
26705 if not Clause_Matched
26706 and then Is_Null_Refined_State
(Dep_Input
)
26707 and then Is_Already_Matched
(Dep_Output
)
26709 Clause_Matched
:= True;
26712 -- A clause where the output is an abstract state with visible null
26713 -- refinement is implicitly matched when the input has already been
26714 -- matched in a previous clause.
26716 -- Refined_State => (State => null)
26717 -- Depends => (State => Input) -- implicitly OK
26718 -- Refined_Depends => (... => Input)
26720 if not Clause_Matched
26721 and then Is_Null_Refined_State
(Dep_Output
)
26722 and then Is_Already_Matched
(Dep_Input
)
26724 Clause_Matched
:= True;
26727 -- At this point either all refinement clauses have been examined or
26728 -- pragma Refined_Depends contains a solitary null. Only an abstract
26729 -- state with null refinement can possibly match these cases.
26731 -- Refined_State => (State => null)
26732 -- Depends => (State => null)
26733 -- Refined_Depends => null -- OK
26735 if not Clause_Matched
then
26737 (Dep_Item
=> Dep_Input
,
26739 Matched
=> Inputs_Match
);
26742 (Dep_Item
=> Dep_Output
,
26744 Matched
=> Outputs_Match
);
26746 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
26749 -- If the contents of Refined_Depends are legal, then the current
26750 -- dependence clause should be satisfied either by an explicit match
26751 -- or by one of the special cases.
26753 if not Clause_Matched
then
26755 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
26756 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
26758 end Check_Dependency_Clause
;
26760 -------------------------
26761 -- Check_Output_States --
26762 -------------------------
26764 procedure Check_Output_States
26765 (Spec_Inputs
: Elist_Id
;
26766 Spec_Outputs
: Elist_Id
;
26767 Body_Inputs
: Elist_Id
;
26768 Body_Outputs
: Elist_Id
)
26770 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26771 -- Determine whether all constituents of state State_Id with full
26772 -- visible refinement are used as outputs in pragma Refined_Depends.
26773 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26775 -----------------------------
26776 -- Check_Constituent_Usage --
26777 -----------------------------
26779 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26780 Constits
: constant Elist_Id
:=
26781 Partial_Refinement_Constituents
(State_Id
);
26782 Constit_Elmt
: Elmt_Id
;
26783 Constit_Id
: Entity_Id
;
26784 Only_Partial
: constant Boolean :=
26785 not Has_Visible_Refinement
(State_Id
);
26786 Posted
: Boolean := False;
26789 if Present
(Constits
) then
26790 Constit_Elmt
:= First_Elmt
(Constits
);
26791 while Present
(Constit_Elmt
) loop
26792 Constit_Id
:= Node
(Constit_Elmt
);
26794 -- Issue an error when a constituent of State_Id is used,
26795 -- and State_Id has only partial visible refinement
26796 -- (SPARK RM 7.2.4(3d)).
26798 if Only_Partial
then
26799 if (Present
(Body_Inputs
)
26800 and then Appears_In
(Body_Inputs
, Constit_Id
))
26802 (Present
(Body_Outputs
)
26803 and then Appears_In
(Body_Outputs
, Constit_Id
))
26805 Error_Msg_Name_1
:= Chars
(State_Id
);
26807 ("constituent & of state % cannot be used in "
26808 & "dependence refinement", N
, Constit_Id
);
26809 Error_Msg_Name_1
:= Chars
(State_Id
);
26810 SPARK_Msg_N
("\use state % instead", N
);
26813 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26815 elsif Present
(Body_Inputs
)
26816 and then Appears_In
(Body_Inputs
, Constit_Id
)
26818 Error_Msg_Name_1
:= Chars
(State_Id
);
26820 ("constituent & of state % must act as output in "
26821 & "dependence refinement", N
, Constit_Id
);
26823 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26825 elsif No
(Body_Outputs
)
26826 or else not Appears_In
(Body_Outputs
, Constit_Id
)
26831 ("output state & must be replaced by all its "
26832 & "constituents in dependence refinement",
26837 ("\constituent & is missing in output list",
26841 Next_Elmt
(Constit_Elmt
);
26844 end Check_Constituent_Usage
;
26849 Item_Elmt
: Elmt_Id
;
26850 Item_Id
: Entity_Id
;
26852 -- Start of processing for Check_Output_States
26855 -- Do not perform this check in an instance because it was already
26856 -- performed successfully in the generic template.
26858 if In_Instance
then
26861 -- Inspect the outputs of pragma Depends looking for a state with a
26862 -- visible refinement.
26864 elsif Present
(Spec_Outputs
) then
26865 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
26866 while Present
(Item_Elmt
) loop
26867 Item
:= Node
(Item_Elmt
);
26869 -- Deal with the mixed nature of the input and output lists
26871 if Nkind
(Item
) = N_Defining_Identifier
then
26874 Item_Id
:= Available_View
(Entity_Of
(Item
));
26877 if Ekind
(Item_Id
) = E_Abstract_State
then
26879 -- The state acts as an input-output, skip it
26881 if Present
(Spec_Inputs
)
26882 and then Appears_In
(Spec_Inputs
, Item_Id
)
26886 -- Ensure that all of the constituents are utilized as
26887 -- outputs in pragma Refined_Depends.
26889 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26890 Check_Constituent_Usage
(Item_Id
);
26894 Next_Elmt
(Item_Elmt
);
26897 end Check_Output_States
;
26899 --------------------
26900 -- Collect_States --
26901 --------------------
26903 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
26904 procedure Collect_State
26906 States
: in out Elist_Id
);
26907 -- Add the entity of Item to list States when it denotes to a state
26909 -------------------
26910 -- Collect_State --
26911 -------------------
26913 procedure Collect_State
26915 States
: in out Elist_Id
)
26920 if Is_Entity_Name
(Item
) then
26921 Id
:= Entity_Of
(Item
);
26923 if Ekind
(Id
) = E_Abstract_State
then
26924 if No
(States
) then
26925 States
:= New_Elmt_List
;
26928 Append_Unique_Elmt
(Id
, States
);
26938 States
: Elist_Id
:= No_Elist
;
26940 -- Start of processing for Collect_States
26943 Clause
:= First
(Clauses
);
26944 while Present
(Clause
) loop
26945 Input
:= Expression
(Clause
);
26946 Output
:= First
(Choices
(Clause
));
26948 Collect_State
(Input
, States
);
26949 Collect_State
(Output
, States
);
26955 end Collect_States
;
26957 -----------------------
26958 -- Normalize_Clauses --
26959 -----------------------
26961 procedure Normalize_Clauses
(Clauses
: List_Id
) is
26962 procedure Normalize_Inputs
(Clause
: Node_Id
);
26963 -- Normalize clause Clause by creating multiple clauses for each
26964 -- input item of Clause. It is assumed that Clause has exactly one
26965 -- output. The transformation is as follows:
26967 -- Output => (Input_1, Input_2) -- original
26969 -- Output => Input_1 -- normalizations
26970 -- Output => Input_2
26972 procedure Normalize_Outputs
(Clause
: Node_Id
);
26973 -- Normalize clause Clause by creating multiple clause for each
26974 -- output item of Clause. The transformation is as follows:
26976 -- (Output_1, Output_2) => Input -- original
26978 -- Output_1 => Input -- normalization
26979 -- Output_2 => Input
26981 ----------------------
26982 -- Normalize_Inputs --
26983 ----------------------
26985 procedure Normalize_Inputs
(Clause
: Node_Id
) is
26986 Inputs
: constant Node_Id
:= Expression
(Clause
);
26987 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26988 Output
: constant List_Id
:= Choices
(Clause
);
26989 Last_Input
: Node_Id
;
26991 New_Clause
: Node_Id
;
26992 Next_Input
: Node_Id
;
26995 -- Normalization is performed only when the original clause has
26996 -- more than one input. Multiple inputs appear as an aggregate.
26998 if Nkind
(Inputs
) = N_Aggregate
then
26999 Last_Input
:= Last
(Expressions
(Inputs
));
27001 -- Create a new clause for each input
27003 Input
:= First
(Expressions
(Inputs
));
27004 while Present
(Input
) loop
27005 Next_Input
:= Next
(Input
);
27007 -- Unhook the current input from the original input list
27008 -- because it will be relocated to a new clause.
27012 -- Special processing for the last input. At this point the
27013 -- original aggregate has been stripped down to one element.
27014 -- Replace the aggregate by the element itself.
27016 if Input
= Last_Input
then
27017 Rewrite
(Inputs
, Input
);
27019 -- Generate a clause of the form:
27024 Make_Component_Association
(Loc
,
27025 Choices
=> New_Copy_List_Tree
(Output
),
27026 Expression
=> Input
);
27028 -- The new clause contains replicated content that has
27029 -- already been analyzed, mark the clause as analyzed.
27031 Set_Analyzed
(New_Clause
);
27032 Insert_After
(Clause
, New_Clause
);
27035 Input
:= Next_Input
;
27038 end Normalize_Inputs
;
27040 -----------------------
27041 -- Normalize_Outputs --
27042 -----------------------
27044 procedure Normalize_Outputs
(Clause
: Node_Id
) is
27045 Inputs
: constant Node_Id
:= Expression
(Clause
);
27046 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
27047 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
27048 Last_Output
: Node_Id
;
27049 New_Clause
: Node_Id
;
27050 Next_Output
: Node_Id
;
27054 -- Multiple outputs appear as an aggregate. Nothing to do when
27055 -- the clause has exactly one output.
27057 if Nkind
(Outputs
) = N_Aggregate
then
27058 Last_Output
:= Last
(Expressions
(Outputs
));
27060 -- Create a clause for each output. Note that each time a new
27061 -- clause is created, the original output list slowly shrinks
27062 -- until there is one item left.
27064 Output
:= First
(Expressions
(Outputs
));
27065 while Present
(Output
) loop
27066 Next_Output
:= Next
(Output
);
27068 -- Unhook the output from the original output list as it
27069 -- will be relocated to a new clause.
27073 -- Special processing for the last output. At this point
27074 -- the original aggregate has been stripped down to one
27075 -- element. Replace the aggregate by the element itself.
27077 if Output
= Last_Output
then
27078 Rewrite
(Outputs
, Output
);
27081 -- Generate a clause of the form:
27082 -- (Output => Inputs)
27085 Make_Component_Association
(Loc
,
27086 Choices
=> New_List
(Output
),
27087 Expression
=> New_Copy_Tree
(Inputs
));
27089 -- The new clause contains replicated content that has
27090 -- already been analyzed. There is not need to reanalyze
27093 Set_Analyzed
(New_Clause
);
27094 Insert_After
(Clause
, New_Clause
);
27097 Output
:= Next_Output
;
27100 end Normalize_Outputs
;
27106 -- Start of processing for Normalize_Clauses
27109 Clause
:= First
(Clauses
);
27110 while Present
(Clause
) loop
27111 Normalize_Outputs
(Clause
);
27115 Clause
:= First
(Clauses
);
27116 while Present
(Clause
) loop
27117 Normalize_Inputs
(Clause
);
27120 end Normalize_Clauses
;
27122 --------------------------
27123 -- Remove_Extra_Clauses --
27124 --------------------------
27126 procedure Remove_Extra_Clauses
27127 (Clauses
: List_Id
;
27128 Matched_Items
: Elist_Id
)
27132 Input_Id
: Entity_Id
;
27133 Next_Clause
: Node_Id
;
27135 State_Id
: Entity_Id
;
27138 Clause
:= First
(Clauses
);
27139 while Present
(Clause
) loop
27140 Next_Clause
:= Next
(Clause
);
27142 Input
:= Expression
(Clause
);
27143 Output
:= First
(Choices
(Clause
));
27145 -- Recognize a clause of the form
27149 -- where Input is a constituent of a state which was already
27150 -- successfully matched. This clause must be removed because it
27151 -- simply indicates that some of the constituents of the state
27154 -- Refined_State => (State => (Constit_1, Constit_2))
27155 -- Depends => (Output => State)
27156 -- Refined_Depends => ((Output => Constit_1), -- State matched
27157 -- (null => Constit_2)) -- OK
27159 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
27161 -- Handle abstract views generated for limited with clauses
27163 Input_Id
:= Available_View
(Entity_Of
(Input
));
27165 -- The input must be a constituent of a state
27167 if Ekind
(Input_Id
) in
27168 E_Abstract_State | E_Constant | E_Variable
27169 and then Present
(Encapsulating_State
(Input_Id
))
27171 State_Id
:= Encapsulating_State
(Input_Id
);
27173 -- The state must have a non-null visible refinement and be
27174 -- matched in a previous clause.
27176 if Has_Non_Null_Visible_Refinement
(State_Id
)
27177 and then Contains
(Matched_Items
, State_Id
)
27183 -- Recognize a clause of the form
27187 -- where Output is an arbitrary item. This clause must be removed
27188 -- because a null input legitimately matches anything.
27190 elsif Nkind
(Input
) = N_Null
then
27194 Clause
:= Next_Clause
;
27196 end Remove_Extra_Clauses
;
27198 --------------------------
27199 -- Report_Extra_Clauses --
27200 --------------------------
27202 procedure Report_Extra_Clauses
(Clauses
: List_Id
) is
27206 -- Do not perform this check in an instance because it was already
27207 -- performed successfully in the generic template.
27209 if In_Instance
then
27212 elsif Present
(Clauses
) then
27213 Clause
:= First
(Clauses
);
27214 while Present
(Clause
) loop
27216 ("unmatched or extra clause in dependence refinement",
27222 end Report_Extra_Clauses
;
27226 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27227 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27228 Errors
: constant Nat
:= Serious_Errors_Detected
;
27235 Body_Inputs
: Elist_Id
:= No_Elist
;
27236 Body_Outputs
: Elist_Id
:= No_Elist
;
27237 -- The inputs and outputs of the subprogram body synthesized from pragma
27238 -- Refined_Depends.
27240 Dependencies
: List_Id
:= No_List
;
27242 -- The corresponding Depends pragma along with its clauses
27244 Matched_Items
: Elist_Id
:= No_Elist
;
27245 -- A list containing the entities of all successfully matched items
27246 -- found in pragma Depends.
27248 Refinements
: List_Id
:= No_List
;
27249 -- The clauses of pragma Refined_Depends
27251 Spec_Id
: Entity_Id
;
27252 -- The entity of the subprogram subject to pragma Refined_Depends
27254 Spec_Inputs
: Elist_Id
:= No_Elist
;
27255 Spec_Outputs
: Elist_Id
:= No_Elist
;
27256 -- The inputs and outputs of the subprogram spec synthesized from pragma
27259 States
: Elist_Id
:= No_Elist
;
27260 -- A list containing the entities of all states whose constituents
27261 -- appear in pragma Depends.
27263 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
27266 -- Do not analyze the pragma multiple times
27268 if Is_Analyzed_Pragma
(N
) then
27272 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
27274 -- Use the anonymous object as the proper spec when Refined_Depends
27275 -- applies to the body of a single task type. The object carries the
27276 -- proper Chars as well as all non-refined versions of pragmas.
27278 if Is_Single_Concurrent_Type
(Spec_Id
) then
27279 Spec_Id
:= Anonymous_Object
(Spec_Id
);
27282 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27284 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
27285 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
27287 if No
(Depends
) then
27289 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
27290 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
27294 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27296 -- A null dependency relation renders the refinement useless because it
27297 -- cannot possibly mention abstract states with visible refinement. Note
27298 -- that the inverse is not true as states may be refined to null
27299 -- (SPARK RM 7.2.5(2)).
27301 if Nkind
(Deps
) = N_Null
then
27303 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
27304 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
27308 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
27309 -- This ensures that the categorization of all refined dependency items
27310 -- is consistent with their role.
27312 Analyze_Depends_In_Decl_Part
(N
);
27314 -- Do not match dependencies against refinements if Refined_Depends is
27315 -- illegal to avoid emitting misleading error.
27317 if Serious_Errors_Detected
= Errors
then
27319 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
27320 -- the inputs and outputs of the subprogram spec and body to verify
27321 -- the use of states with visible refinement and their constituents.
27323 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
27324 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
27326 Collect_Subprogram_Inputs_Outputs
27327 (Subp_Id
=> Spec_Id
,
27328 Synthesize
=> True,
27329 Subp_Inputs
=> Spec_Inputs
,
27330 Subp_Outputs
=> Spec_Outputs
,
27331 Global_Seen
=> Dummy
);
27333 Collect_Subprogram_Inputs_Outputs
27334 (Subp_Id
=> Body_Id
,
27335 Synthesize
=> True,
27336 Subp_Inputs
=> Body_Inputs
,
27337 Subp_Outputs
=> Body_Outputs
,
27338 Global_Seen
=> Dummy
);
27340 -- For an output state with a visible refinement, ensure that all
27341 -- constituents appear as outputs in the dependency refinement.
27343 Check_Output_States
27344 (Spec_Inputs
=> Spec_Inputs
,
27345 Spec_Outputs
=> Spec_Outputs
,
27346 Body_Inputs
=> Body_Inputs
,
27347 Body_Outputs
=> Body_Outputs
);
27350 -- Multiple dependency clauses appear as component associations of an
27351 -- aggregate. Note that the clauses are copied because the algorithm
27352 -- modifies them and this should not be visible in Depends.
27354 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
27355 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
27356 Normalize_Clauses
(Dependencies
);
27358 -- Gather all states which appear in Depends
27360 States
:= Collect_States
(Dependencies
);
27362 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
27364 if Nkind
(Refs
) = N_Null
then
27365 Refinements
:= No_List
;
27367 -- Multiple dependency clauses appear as component associations of an
27368 -- aggregate. Note that the clauses are copied because the algorithm
27369 -- modifies them and this should not be visible in Refined_Depends.
27371 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
27372 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
27373 Normalize_Clauses
(Refinements
);
27376 -- At this point the clauses of pragmas Depends and Refined_Depends
27377 -- have been normalized into simple dependencies between one output
27378 -- and one input. Examine all clauses of pragma Depends looking for
27379 -- matching clauses in pragma Refined_Depends.
27381 Clause
:= First
(Dependencies
);
27382 while Present
(Clause
) loop
27383 Check_Dependency_Clause
27384 (Spec_Id
=> Spec_Id
,
27385 Dep_Clause
=> Clause
,
27386 Dep_States
=> States
,
27387 Refinements
=> Refinements
,
27388 Matched_Items
=> Matched_Items
);
27393 -- Pragma Refined_Depends may contain multiple clarification clauses
27394 -- which indicate that certain constituents do not influence the data
27395 -- flow in any way. Such clauses must be removed as long as the state
27396 -- has been matched, otherwise they will be incorrectly flagged as
27399 -- Refined_State => (State => (Constit_1, Constit_2))
27400 -- Depends => (Output => State)
27401 -- Refined_Depends => ((Output => Constit_1), -- State matched
27402 -- (null => Constit_2)) -- must be removed
27404 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
27406 if Serious_Errors_Detected
= Errors
then
27407 Report_Extra_Clauses
(Refinements
);
27412 Set_Is_Analyzed_Pragma
(N
);
27413 end Analyze_Refined_Depends_In_Decl_Part
;
27415 -----------------------------------------
27416 -- Analyze_Refined_Global_In_Decl_Part --
27417 -----------------------------------------
27419 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
27421 -- The corresponding Global pragma
27423 Has_In_State
: Boolean := False;
27424 Has_In_Out_State
: Boolean := False;
27425 Has_Out_State
: Boolean := False;
27426 Has_Proof_In_State
: Boolean := False;
27427 -- These flags are set when the corresponding Global pragma has a state
27428 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27431 Has_Null_State
: Boolean := False;
27432 -- This flag is set when the corresponding Global pragma has at least
27433 -- one state with a null refinement.
27435 In_Constits
: Elist_Id
:= No_Elist
;
27436 In_Out_Constits
: Elist_Id
:= No_Elist
;
27437 Out_Constits
: Elist_Id
:= No_Elist
;
27438 Proof_In_Constits
: Elist_Id
:= No_Elist
;
27439 -- These lists contain the entities of all Input, In_Out, Output and
27440 -- Proof_In constituents that appear in Refined_Global and participate
27441 -- in state refinement.
27443 In_Items
: Elist_Id
:= No_Elist
;
27444 In_Out_Items
: Elist_Id
:= No_Elist
;
27445 Out_Items
: Elist_Id
:= No_Elist
;
27446 Proof_In_Items
: Elist_Id
:= No_Elist
;
27447 -- These lists contain the entities of all Input, In_Out, Output and
27448 -- Proof_In items defined in the corresponding Global pragma.
27450 Repeat_Items
: Elist_Id
:= No_Elist
;
27451 -- A list of all global items without full visible refinement found
27452 -- in pragma Global. These states should be repeated in the global
27453 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27454 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27456 Spec_Id
: Entity_Id
;
27457 -- The entity of the subprogram subject to pragma Refined_Global
27459 States
: Elist_Id
:= No_Elist
;
27460 -- A list of all states with full or partial visible refinement found in
27463 procedure Check_In_Out_States
;
27464 -- Determine whether the corresponding Global pragma mentions In_Out
27465 -- states with visible refinement and if so, ensure that one of the
27466 -- following completions apply to the constituents of the state:
27467 -- 1) there is at least one constituent of mode In_Out
27468 -- 2) there is at least one Input and one Output constituent
27469 -- 3) not all constituents are present and one of them is of mode
27471 -- This routine may remove elements from In_Constits, In_Out_Constits,
27472 -- Out_Constits and Proof_In_Constits.
27474 procedure Check_Input_States
;
27475 -- Determine whether the corresponding Global pragma mentions Input
27476 -- states with visible refinement and if so, ensure that at least one of
27477 -- its constituents appears as an Input item in Refined_Global.
27478 -- This routine may remove elements from In_Constits, In_Out_Constits,
27479 -- Out_Constits and Proof_In_Constits.
27481 procedure Check_Output_States
;
27482 -- Determine whether the corresponding Global pragma mentions Output
27483 -- states with visible refinement and if so, ensure that all of its
27484 -- constituents appear as Output items in Refined_Global.
27485 -- This routine may remove elements from In_Constits, In_Out_Constits,
27486 -- Out_Constits and Proof_In_Constits.
27488 procedure Check_Proof_In_States
;
27489 -- Determine whether the corresponding Global pragma mentions Proof_In
27490 -- states with visible refinement and if so, ensure that at least one of
27491 -- its constituents appears as a Proof_In item in Refined_Global.
27492 -- This routine may remove elements from In_Constits, In_Out_Constits,
27493 -- Out_Constits and Proof_In_Constits.
27495 procedure Check_Refined_Global_List
27497 Global_Mode
: Name_Id
:= Name_Input
);
27498 -- Verify the legality of a single global list declaration. Global_Mode
27499 -- denotes the current mode in effect.
27501 procedure Collect_Global_Items
27503 Mode
: Name_Id
:= Name_Input
);
27504 -- Gather all Input, In_Out, Output and Proof_In items from node List
27505 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27506 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27507 -- and Has_Proof_In_State are set when there is at least one abstract
27508 -- state with full or partial visible refinement available in the
27509 -- corresponding mode. Flag Has_Null_State is set when at least state
27510 -- has a null refinement. Mode denotes the current global mode in
27513 function Present_Then_Remove
27515 Item
: Entity_Id
) return Boolean;
27516 -- Search List for a particular entity Item. If Item has been found,
27517 -- remove it from List. This routine is used to strip lists In_Constits,
27518 -- In_Out_Constits and Out_Constits of valid constituents.
27520 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
27521 -- Same as function Present_Then_Remove, but do not report the presence
27522 -- of Item in List.
27524 procedure Report_Extra_Constituents
;
27525 -- Emit an error for each constituent found in lists In_Constits,
27526 -- In_Out_Constits and Out_Constits.
27528 procedure Report_Missing_Items
;
27529 -- Emit an error for each global item not repeated found in list
27532 -------------------------
27533 -- Check_In_Out_States --
27534 -------------------------
27536 procedure Check_In_Out_States
is
27537 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27538 -- Determine whether one of the following coverage scenarios is in
27540 -- 1) there is at least one constituent of mode In_Out or Output
27541 -- 2) there is at least one pair of constituents with modes Input
27542 -- and Output, or Proof_In and Output.
27543 -- 3) there is at least one constituent of mode Output and not all
27544 -- constituents are present.
27545 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27547 -----------------------------
27548 -- Check_Constituent_Usage --
27549 -----------------------------
27551 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27552 Constits
: constant Elist_Id
:=
27553 Partial_Refinement_Constituents
(State_Id
);
27554 Constit_Elmt
: Elmt_Id
;
27555 Constit_Id
: Entity_Id
;
27556 Has_Missing
: Boolean := False;
27557 In_Out_Seen
: Boolean := False;
27558 Input_Seen
: Boolean := False;
27559 Output_Seen
: Boolean := False;
27560 Proof_In_Seen
: Boolean := False;
27563 -- Process all the constituents of the state and note their modes
27564 -- within the global refinement.
27566 if Present
(Constits
) then
27567 Constit_Elmt
:= First_Elmt
(Constits
);
27568 while Present
(Constit_Elmt
) loop
27569 Constit_Id
:= Node
(Constit_Elmt
);
27571 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27572 Input_Seen
:= True;
27574 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
27575 In_Out_Seen
:= True;
27577 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27578 Output_Seen
:= True;
27580 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27582 Proof_In_Seen
:= True;
27585 Has_Missing
:= True;
27588 Next_Elmt
(Constit_Elmt
);
27592 -- An In_Out constituent is a valid completion
27594 if In_Out_Seen
then
27597 -- A pair of one Input/Proof_In and one Output constituent is a
27598 -- valid completion.
27600 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
27603 elsif Output_Seen
then
27605 -- A single Output constituent is a valid completion only when
27606 -- some of the other constituents are missing.
27608 if Has_Missing
then
27611 -- Otherwise all constituents are of mode Output
27615 ("global refinement of state & must include at least one "
27616 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27620 -- The state lacks a completion. When full refinement is visible,
27621 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27622 -- refinement is visible, emit an error if the abstract state
27623 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27624 -- both are utilized, Check_State_And_Constituent_Use. will issue
27627 elsif not Input_Seen
27628 and then not In_Out_Seen
27629 and then not Output_Seen
27630 and then not Proof_In_Seen
27632 if Has_Visible_Refinement
(State_Id
)
27633 or else Contains
(Repeat_Items
, State_Id
)
27636 ("missing global refinement of state &", N
, State_Id
);
27639 -- Otherwise the state has a malformed completion where at least
27640 -- one of the constituents has a different mode.
27644 ("global refinement of state & redefines the mode of its "
27645 & "constituents", N
, State_Id
);
27647 end Check_Constituent_Usage
;
27651 Item_Elmt
: Elmt_Id
;
27652 Item_Id
: Entity_Id
;
27654 -- Start of processing for Check_In_Out_States
27657 -- Do not perform this check in an instance because it was already
27658 -- performed successfully in the generic template.
27660 if In_Instance
then
27663 -- Inspect the In_Out items of the corresponding Global pragma
27664 -- looking for a state with a visible refinement.
27666 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
27667 Item_Elmt
:= First_Elmt
(In_Out_Items
);
27668 while Present
(Item_Elmt
) loop
27669 Item_Id
:= Node
(Item_Elmt
);
27671 -- Ensure that one of the three coverage variants is satisfied
27673 if Ekind
(Item_Id
) = E_Abstract_State
27674 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27676 Check_Constituent_Usage
(Item_Id
);
27679 Next_Elmt
(Item_Elmt
);
27682 end Check_In_Out_States
;
27684 ------------------------
27685 -- Check_Input_States --
27686 ------------------------
27688 procedure Check_Input_States
is
27689 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27690 -- Determine whether at least one constituent of state State_Id with
27691 -- full or partial visible refinement is used and has mode Input.
27692 -- Ensure that the remaining constituents do not have In_Out or
27693 -- Output modes. Emit an error if this is not the case
27694 -- (SPARK RM 7.2.4(5)).
27696 -----------------------------
27697 -- Check_Constituent_Usage --
27698 -----------------------------
27700 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27701 Constits
: constant Elist_Id
:=
27702 Partial_Refinement_Constituents
(State_Id
);
27703 Constit_Elmt
: Elmt_Id
;
27704 Constit_Id
: Entity_Id
;
27705 In_Seen
: Boolean := False;
27708 if Present
(Constits
) then
27709 Constit_Elmt
:= First_Elmt
(Constits
);
27710 while Present
(Constit_Elmt
) loop
27711 Constit_Id
:= Node
(Constit_Elmt
);
27713 -- At least one of the constituents appears as an Input
27715 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27718 -- A Proof_In constituent can refine an Input state as long
27719 -- as there is at least one Input constituent present.
27721 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27725 -- The constituent appears in the global refinement, but has
27726 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27728 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27729 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27731 Error_Msg_Name_1
:= Chars
(State_Id
);
27733 ("constituent & of state % must have mode `Input` in "
27734 & "global refinement", N
, Constit_Id
);
27737 Next_Elmt
(Constit_Elmt
);
27741 -- Not one of the constituents appeared as Input. Always emit an
27742 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27743 -- When only partial refinement is visible, emit an error if the
27744 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27745 -- the case where both are utilized, an error will be issued in
27746 -- Check_State_And_Constituent_Use.
27749 and then (Has_Visible_Refinement
(State_Id
)
27750 or else Contains
(Repeat_Items
, State_Id
))
27753 ("global refinement of state & must include at least one "
27754 & "constituent of mode `Input`", N
, State_Id
);
27756 end Check_Constituent_Usage
;
27760 Item_Elmt
: Elmt_Id
;
27761 Item_Id
: Entity_Id
;
27763 -- Start of processing for Check_Input_States
27766 -- Do not perform this check in an instance because it was already
27767 -- performed successfully in the generic template.
27769 if In_Instance
then
27772 -- Inspect the Input items of the corresponding Global pragma looking
27773 -- for a state with a visible refinement.
27775 elsif Has_In_State
and then Present
(In_Items
) then
27776 Item_Elmt
:= First_Elmt
(In_Items
);
27777 while Present
(Item_Elmt
) loop
27778 Item_Id
:= Node
(Item_Elmt
);
27780 -- When full refinement is visible, ensure that at least one of
27781 -- the constituents is utilized and is of mode Input. When only
27782 -- partial refinement is visible, ensure that either one of
27783 -- the constituents is utilized and is of mode Input, or the
27784 -- abstract state is repeated and no constituent is utilized.
27786 if Ekind
(Item_Id
) = E_Abstract_State
27787 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27789 Check_Constituent_Usage
(Item_Id
);
27792 Next_Elmt
(Item_Elmt
);
27795 end Check_Input_States
;
27797 -------------------------
27798 -- Check_Output_States --
27799 -------------------------
27801 procedure Check_Output_States
is
27802 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27803 -- Determine whether all constituents of state State_Id with full
27804 -- visible refinement are used and have mode Output. Emit an error
27805 -- if this is not the case (SPARK RM 7.2.4(5)).
27807 -----------------------------
27808 -- Check_Constituent_Usage --
27809 -----------------------------
27811 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27812 Constits
: constant Elist_Id
:=
27813 Partial_Refinement_Constituents
(State_Id
);
27814 Only_Partial
: constant Boolean :=
27815 not Has_Visible_Refinement
(State_Id
);
27816 Constit_Elmt
: Elmt_Id
;
27817 Constit_Id
: Entity_Id
;
27818 Posted
: Boolean := False;
27821 if Present
(Constits
) then
27822 Constit_Elmt
:= First_Elmt
(Constits
);
27823 while Present
(Constit_Elmt
) loop
27824 Constit_Id
:= Node
(Constit_Elmt
);
27826 -- Issue an error when a constituent of State_Id is utilized
27827 -- and State_Id has only partial visible refinement
27828 -- (SPARK RM 7.2.4(3d)).
27830 if Only_Partial
then
27831 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
27832 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
27834 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27836 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27838 Error_Msg_Name_1
:= Chars
(State_Id
);
27840 ("constituent & of state % cannot be used in global "
27841 & "refinement", N
, Constit_Id
);
27842 Error_Msg_Name_1
:= Chars
(State_Id
);
27843 SPARK_Msg_N
("\use state % instead", N
);
27846 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27849 -- The constituent appears in the global refinement, but has
27850 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27852 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27853 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27854 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27856 Error_Msg_Name_1
:= Chars
(State_Id
);
27858 ("constituent & of state % must have mode `Output` in "
27859 & "global refinement", N
, Constit_Id
);
27861 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27867 ("`Output` state & must be replaced by all its "
27868 & "constituents in global refinement", N
, State_Id
);
27872 ("\constituent & is missing in output list",
27876 Next_Elmt
(Constit_Elmt
);
27879 end Check_Constituent_Usage
;
27883 Item_Elmt
: Elmt_Id
;
27884 Item_Id
: Entity_Id
;
27886 -- Start of processing for Check_Output_States
27889 -- Do not perform this check in an instance because it was already
27890 -- performed successfully in the generic template.
27892 if In_Instance
then
27895 -- Inspect the Output items of the corresponding Global pragma
27896 -- looking for a state with a visible refinement.
27898 elsif Has_Out_State
and then Present
(Out_Items
) then
27899 Item_Elmt
:= First_Elmt
(Out_Items
);
27900 while Present
(Item_Elmt
) loop
27901 Item_Id
:= Node
(Item_Elmt
);
27903 -- When full refinement is visible, ensure that all of the
27904 -- constituents are utilized and they have mode Output. When
27905 -- only partial refinement is visible, ensure that no
27906 -- constituent is utilized.
27908 if Ekind
(Item_Id
) = E_Abstract_State
27909 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27911 Check_Constituent_Usage
(Item_Id
);
27914 Next_Elmt
(Item_Elmt
);
27917 end Check_Output_States
;
27919 ---------------------------
27920 -- Check_Proof_In_States --
27921 ---------------------------
27923 procedure Check_Proof_In_States
is
27924 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27925 -- Determine whether at least one constituent of state State_Id with
27926 -- full or partial visible refinement is used and has mode Proof_In.
27927 -- Ensure that the remaining constituents do not have Input, In_Out,
27928 -- or Output modes. Emit an error if this is not the case
27929 -- (SPARK RM 7.2.4(5)).
27931 -----------------------------
27932 -- Check_Constituent_Usage --
27933 -----------------------------
27935 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27936 Constits
: constant Elist_Id
:=
27937 Partial_Refinement_Constituents
(State_Id
);
27938 Constit_Elmt
: Elmt_Id
;
27939 Constit_Id
: Entity_Id
;
27940 Proof_In_Seen
: Boolean := False;
27943 if Present
(Constits
) then
27944 Constit_Elmt
:= First_Elmt
(Constits
);
27945 while Present
(Constit_Elmt
) loop
27946 Constit_Id
:= Node
(Constit_Elmt
);
27948 -- At least one of the constituents appears as Proof_In
27950 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
27951 Proof_In_Seen
:= True;
27953 -- The constituent appears in the global refinement, but has
27954 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27956 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27957 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27958 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27960 Error_Msg_Name_1
:= Chars
(State_Id
);
27962 ("constituent & of state % must have mode `Proof_In` "
27963 & "in global refinement", N
, Constit_Id
);
27966 Next_Elmt
(Constit_Elmt
);
27970 -- Not one of the constituents appeared as Proof_In. Always emit
27971 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27972 -- When only partial refinement is visible, emit an error if the
27973 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27974 -- the case where both are utilized, an error will be issued by
27975 -- Check_State_And_Constituent_Use.
27977 if not Proof_In_Seen
27978 and then (Has_Visible_Refinement
(State_Id
)
27979 or else Contains
(Repeat_Items
, State_Id
))
27982 ("global refinement of state & must include at least one "
27983 & "constituent of mode `Proof_In`", N
, State_Id
);
27985 end Check_Constituent_Usage
;
27989 Item_Elmt
: Elmt_Id
;
27990 Item_Id
: Entity_Id
;
27992 -- Start of processing for Check_Proof_In_States
27995 -- Do not perform this check in an instance because it was already
27996 -- performed successfully in the generic template.
27998 if In_Instance
then
28001 -- Inspect the Proof_In items of the corresponding Global pragma
28002 -- looking for a state with a visible refinement.
28004 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
28005 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
28006 while Present
(Item_Elmt
) loop
28007 Item_Id
:= Node
(Item_Elmt
);
28009 -- Ensure that at least one of the constituents is utilized
28010 -- and is of mode Proof_In. When only partial refinement is
28011 -- visible, ensure that either one of the constituents is
28012 -- utilized and is of mode Proof_In, or the abstract state
28013 -- is repeated and no constituent is utilized.
28015 if Ekind
(Item_Id
) = E_Abstract_State
28016 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
28018 Check_Constituent_Usage
(Item_Id
);
28021 Next_Elmt
(Item_Elmt
);
28024 end Check_Proof_In_States
;
28026 -------------------------------
28027 -- Check_Refined_Global_List --
28028 -------------------------------
28030 procedure Check_Refined_Global_List
28032 Global_Mode
: Name_Id
:= Name_Input
)
28034 procedure Check_Refined_Global_Item
28036 Global_Mode
: Name_Id
);
28037 -- Verify the legality of a single global item declaration. Parameter
28038 -- Global_Mode denotes the current mode in effect.
28040 -------------------------------
28041 -- Check_Refined_Global_Item --
28042 -------------------------------
28044 procedure Check_Refined_Global_Item
28046 Global_Mode
: Name_Id
)
28048 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
28050 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
28051 -- Issue a common error message for all mode mismatches. Expect
28052 -- denotes the expected mode.
28054 -----------------------------
28055 -- Inconsistent_Mode_Error --
28056 -----------------------------
28058 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
28061 ("global item & has inconsistent modes", Item
, Item_Id
);
28063 Error_Msg_Name_1
:= Global_Mode
;
28064 Error_Msg_Name_2
:= Expect
;
28065 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
28066 end Inconsistent_Mode_Error
;
28070 Enc_State
: Entity_Id
:= Empty
;
28071 -- Encapsulating state for constituent, Empty otherwise
28073 -- Start of processing for Check_Refined_Global_Item
28076 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
28078 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
28081 -- When the state or object acts as a constituent of another
28082 -- state with a visible refinement, collect it for the state
28083 -- completeness checks performed later on. Note that the item
28084 -- acts as a constituent only when the encapsulating state is
28085 -- present in pragma Global.
28087 if Present
(Enc_State
)
28088 and then (Has_Visible_Refinement
(Enc_State
)
28089 or else Has_Partial_Visible_Refinement
(Enc_State
))
28090 and then Contains
(States
, Enc_State
)
28092 -- If the state has only partial visible refinement, remove it
28093 -- from the list of items that should be repeated from pragma
28096 if not Has_Visible_Refinement
(Enc_State
) then
28097 Present_Then_Remove
(Repeat_Items
, Enc_State
);
28100 if Global_Mode
= Name_Input
then
28101 Append_New_Elmt
(Item_Id
, In_Constits
);
28103 elsif Global_Mode
= Name_In_Out
then
28104 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
28106 elsif Global_Mode
= Name_Output
then
28107 Append_New_Elmt
(Item_Id
, Out_Constits
);
28109 elsif Global_Mode
= Name_Proof_In
then
28110 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
28113 -- When not a constituent, ensure that both occurrences of the
28114 -- item in pragmas Global and Refined_Global match. Also remove
28115 -- it when present from the list of items that should be repeated
28116 -- from pragma Global.
28119 Present_Then_Remove
(Repeat_Items
, Item_Id
);
28121 if Contains
(In_Items
, Item_Id
) then
28122 if Global_Mode
/= Name_Input
then
28123 Inconsistent_Mode_Error
(Name_Input
);
28126 elsif Contains
(In_Out_Items
, Item_Id
) then
28127 if Global_Mode
/= Name_In_Out
then
28128 Inconsistent_Mode_Error
(Name_In_Out
);
28131 elsif Contains
(Out_Items
, Item_Id
) then
28132 if Global_Mode
/= Name_Output
then
28133 Inconsistent_Mode_Error
(Name_Output
);
28136 elsif Contains
(Proof_In_Items
, Item_Id
) then
28139 -- The item does not appear in the corresponding Global pragma,
28140 -- it must be an extra (SPARK RM 7.2.4(3)).
28143 pragma Assert
(Present
(Global
));
28144 Error_Msg_Sloc
:= Sloc
(Global
);
28146 ("extra global item & does not refine or repeat any "
28147 & "global item #", Item
, Item_Id
);
28150 end Check_Refined_Global_Item
;
28156 -- Start of processing for Check_Refined_Global_List
28159 -- Do not perform this check in an instance because it was already
28160 -- performed successfully in the generic template.
28162 if In_Instance
then
28165 elsif Nkind
(List
) = N_Null
then
28168 -- Single global item declaration
28170 elsif Nkind
(List
) in N_Expanded_Name
28172 | N_Selected_Component
28174 Check_Refined_Global_Item
(List
, Global_Mode
);
28176 -- Simple global list or moded global list declaration
28178 elsif Nkind
(List
) = N_Aggregate
then
28180 -- The declaration of a simple global list appear as a collection
28183 if Present
(Expressions
(List
)) then
28184 Item
:= First
(Expressions
(List
));
28185 while Present
(Item
) loop
28186 Check_Refined_Global_Item
(Item
, Global_Mode
);
28190 -- The declaration of a moded global list appears as a collection
28191 -- of component associations where individual choices denote
28194 elsif Present
(Component_Associations
(List
)) then
28195 Item
:= First
(Component_Associations
(List
));
28196 while Present
(Item
) loop
28197 Check_Refined_Global_List
28198 (List
=> Expression
(Item
),
28199 Global_Mode
=> Chars
(First
(Choices
(Item
))));
28207 raise Program_Error
;
28213 raise Program_Error
;
28215 end Check_Refined_Global_List
;
28217 --------------------------
28218 -- Collect_Global_Items --
28219 --------------------------
28221 procedure Collect_Global_Items
28223 Mode
: Name_Id
:= Name_Input
)
28225 procedure Collect_Global_Item
28227 Item_Mode
: Name_Id
);
28228 -- Add a single item to the appropriate list. Item_Mode denotes the
28229 -- current mode in effect.
28231 -------------------------
28232 -- Collect_Global_Item --
28233 -------------------------
28235 procedure Collect_Global_Item
28237 Item_Mode
: Name_Id
)
28239 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
28240 -- The above handles abstract views of variables and states built
28241 -- for limited with clauses.
28244 -- Signal that the global list contains at least one abstract
28245 -- state with a visible refinement. Note that the refinement may
28246 -- be null in which case there are no constituents.
28248 if Ekind
(Item_Id
) = E_Abstract_State
then
28249 if Has_Null_Visible_Refinement
(Item_Id
) then
28250 Has_Null_State
:= True;
28252 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
28253 Append_New_Elmt
(Item_Id
, States
);
28255 if Item_Mode
= Name_Input
then
28256 Has_In_State
:= True;
28257 elsif Item_Mode
= Name_In_Out
then
28258 Has_In_Out_State
:= True;
28259 elsif Item_Mode
= Name_Output
then
28260 Has_Out_State
:= True;
28261 elsif Item_Mode
= Name_Proof_In
then
28262 Has_Proof_In_State
:= True;
28267 -- Record global items without full visible refinement found in
28268 -- pragma Global which should be repeated in the global refinement
28269 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
28271 if Ekind
(Item_Id
) /= E_Abstract_State
28272 or else not Has_Visible_Refinement
(Item_Id
)
28274 Append_New_Elmt
(Item_Id
, Repeat_Items
);
28277 -- Add the item to the proper list
28279 if Item_Mode
= Name_Input
then
28280 Append_New_Elmt
(Item_Id
, In_Items
);
28281 elsif Item_Mode
= Name_In_Out
then
28282 Append_New_Elmt
(Item_Id
, In_Out_Items
);
28283 elsif Item_Mode
= Name_Output
then
28284 Append_New_Elmt
(Item_Id
, Out_Items
);
28285 elsif Item_Mode
= Name_Proof_In
then
28286 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
28288 end Collect_Global_Item
;
28294 -- Start of processing for Collect_Global_Items
28297 if Nkind
(List
) = N_Null
then
28300 -- Single global item declaration
28302 elsif Nkind
(List
) in N_Expanded_Name
28304 | N_Selected_Component
28306 Collect_Global_Item
(List
, Mode
);
28308 -- Single global list or moded global list declaration
28310 elsif Nkind
(List
) = N_Aggregate
then
28312 -- The declaration of a simple global list appear as a collection
28315 if Present
(Expressions
(List
)) then
28316 Item
:= First
(Expressions
(List
));
28317 while Present
(Item
) loop
28318 Collect_Global_Item
(Item
, Mode
);
28322 -- The declaration of a moded global list appears as a collection
28323 -- of component associations where individual choices denote mode.
28325 elsif Present
(Component_Associations
(List
)) then
28326 Item
:= First
(Component_Associations
(List
));
28327 while Present
(Item
) loop
28328 Collect_Global_Items
28329 (List
=> Expression
(Item
),
28330 Mode
=> Chars
(First
(Choices
(Item
))));
28338 raise Program_Error
;
28341 -- To accommodate partial decoration of disabled SPARK features, this
28342 -- routine may be called with illegal input. If this is the case, do
28343 -- not raise Program_Error.
28348 end Collect_Global_Items
;
28350 -------------------------
28351 -- Present_Then_Remove --
28352 -------------------------
28354 function Present_Then_Remove
28356 Item
: Entity_Id
) return Boolean
28361 if Present
(List
) then
28362 Elmt
:= First_Elmt
(List
);
28363 while Present
(Elmt
) loop
28364 if Node
(Elmt
) = Item
then
28365 Remove_Elmt
(List
, Elmt
);
28374 end Present_Then_Remove
;
28376 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
28379 Ignore
:= Present_Then_Remove
(List
, Item
);
28380 end Present_Then_Remove
;
28382 -------------------------------
28383 -- Report_Extra_Constituents --
28384 -------------------------------
28386 procedure Report_Extra_Constituents
is
28387 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
28388 -- Emit an error for every element of List
28390 ---------------------------------------
28391 -- Report_Extra_Constituents_In_List --
28392 ---------------------------------------
28394 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
28395 Constit_Elmt
: Elmt_Id
;
28398 if Present
(List
) then
28399 Constit_Elmt
:= First_Elmt
(List
);
28400 while Present
(Constit_Elmt
) loop
28401 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
28402 Next_Elmt
(Constit_Elmt
);
28405 end Report_Extra_Constituents_In_List
;
28407 -- Start of processing for Report_Extra_Constituents
28410 -- Do not perform this check in an instance because it was already
28411 -- performed successfully in the generic template.
28413 if In_Instance
then
28417 Report_Extra_Constituents_In_List
(In_Constits
);
28418 Report_Extra_Constituents_In_List
(In_Out_Constits
);
28419 Report_Extra_Constituents_In_List
(Out_Constits
);
28420 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
28422 end Report_Extra_Constituents
;
28424 --------------------------
28425 -- Report_Missing_Items --
28426 --------------------------
28428 procedure Report_Missing_Items
is
28429 Item_Elmt
: Elmt_Id
;
28430 Item_Id
: Entity_Id
;
28433 -- Do not perform this check in an instance because it was already
28434 -- performed successfully in the generic template.
28436 if In_Instance
then
28440 if Present
(Repeat_Items
) then
28441 Item_Elmt
:= First_Elmt
(Repeat_Items
);
28442 while Present
(Item_Elmt
) loop
28443 Item_Id
:= Node
(Item_Elmt
);
28444 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
28445 Next_Elmt
(Item_Elmt
);
28449 end Report_Missing_Items
;
28453 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28454 Errors
: constant Nat
:= Serious_Errors_Detected
;
28456 No_Constit
: Boolean;
28458 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28461 -- Do not analyze the pragma multiple times
28463 if Is_Analyzed_Pragma
(N
) then
28467 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28469 -- Use the anonymous object as the proper spec when Refined_Global
28470 -- applies to the body of a single task type. The object carries the
28471 -- proper Chars as well as all non-refined versions of pragmas.
28473 if Is_Single_Concurrent_Type
(Spec_Id
) then
28474 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28477 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28478 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
28480 -- The subprogram declaration lacks pragma Global. This renders
28481 -- Refined_Global useless as there is nothing to refine.
28483 if No
(Global
) then
28485 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28486 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
28490 -- Extract all relevant items from the corresponding Global pragma
28492 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28494 -- Package and subprogram bodies are instantiated individually in
28495 -- a separate compiler pass. Due to this mode of instantiation, the
28496 -- refinement of a state may no longer be visible when a subprogram
28497 -- body contract is instantiated. Since the generic template is legal,
28498 -- do not perform this check in the instance to circumvent this oddity.
28500 if In_Instance
then
28503 -- Non-instance case
28506 -- The corresponding Global pragma must mention at least one
28507 -- state with a visible refinement at the point Refined_Global
28508 -- is processed. States with null refinements need Refined_Global
28509 -- pragma (SPARK RM 7.2.4(2)).
28511 if not Has_In_State
28512 and then not Has_In_Out_State
28513 and then not Has_Out_State
28514 and then not Has_Proof_In_State
28515 and then not Has_Null_State
28518 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28519 & "depend on abstract state with visible refinement"),
28523 -- The global refinement of inputs and outputs cannot be null when
28524 -- the corresponding Global pragma contains at least one item except
28525 -- in the case where we have states with null refinements.
28527 elsif Nkind
(Items
) = N_Null
28529 (Present
(In_Items
)
28530 or else Present
(In_Out_Items
)
28531 or else Present
(Out_Items
)
28532 or else Present
(Proof_In_Items
))
28533 and then not Has_Null_State
28536 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
28537 & "global items"), N
, Spec_Id
);
28542 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28543 -- This ensures that the categorization of all refined global items is
28544 -- consistent with their role.
28546 Analyze_Global_In_Decl_Part
(N
);
28548 -- Perform all refinement checks with respect to completeness and mode
28551 if Serious_Errors_Detected
= Errors
then
28552 Check_Refined_Global_List
(Items
);
28555 -- Store the information that no constituent is used in the global
28556 -- refinement, prior to calling checking procedures which remove items
28557 -- from the list of constituents.
28561 and then No
(In_Out_Constits
)
28562 and then No
(Out_Constits
)
28563 and then No
(Proof_In_Constits
);
28565 -- For Input states with visible refinement, at least one constituent
28566 -- must be used as an Input in the global refinement.
28568 if Serious_Errors_Detected
= Errors
then
28569 Check_Input_States
;
28572 -- Verify all possible completion variants for In_Out states with
28573 -- visible refinement.
28575 if Serious_Errors_Detected
= Errors
then
28576 Check_In_Out_States
;
28579 -- For Output states with visible refinement, all constituents must be
28580 -- used as Outputs in the global refinement.
28582 if Serious_Errors_Detected
= Errors
then
28583 Check_Output_States
;
28586 -- For Proof_In states with visible refinement, at least one constituent
28587 -- must be used as Proof_In in the global refinement.
28589 if Serious_Errors_Detected
= Errors
then
28590 Check_Proof_In_States
;
28593 -- Emit errors for all constituents that belong to other states with
28594 -- visible refinement that do not appear in Global.
28596 if Serious_Errors_Detected
= Errors
then
28597 Report_Extra_Constituents
;
28600 -- Emit errors for all items in Global that are not repeated in the
28601 -- global refinement and for which there is no full visible refinement
28602 -- and, in the case of states with partial visible refinement, no
28603 -- constituent is mentioned in the global refinement.
28605 if Serious_Errors_Detected
= Errors
then
28606 Report_Missing_Items
;
28609 -- Emit an error if no constituent is used in the global refinement
28610 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28611 -- one may be issued by the checking procedures. Do not perform this
28612 -- check in an instance because it was already performed successfully
28613 -- in the generic template.
28615 if Serious_Errors_Detected
= Errors
28616 and then not In_Instance
28617 and then not Has_Null_State
28618 and then No_Constit
28620 SPARK_Msg_N
("missing refinement", N
);
28624 Set_Is_Analyzed_Pragma
(N
);
28625 end Analyze_Refined_Global_In_Decl_Part
;
28627 ----------------------------------------
28628 -- Analyze_Refined_State_In_Decl_Part --
28629 ----------------------------------------
28631 procedure Analyze_Refined_State_In_Decl_Part
28633 Freeze_Id
: Entity_Id
:= Empty
)
28635 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
28636 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28637 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
28639 Available_States
: Elist_Id
:= No_Elist
;
28640 -- A list of all abstract states defined in the package declaration that
28641 -- are available for refinement. The list is used to report unrefined
28644 Body_States
: Elist_Id
:= No_Elist
;
28645 -- A list of all hidden states that appear in the body of the related
28646 -- package. The list is used to report unused hidden states.
28648 Constituents_Seen
: Elist_Id
:= No_Elist
;
28649 -- A list that contains all constituents processed so far. The list is
28650 -- used to detect multiple uses of the same constituent.
28652 Freeze_Posted
: Boolean := False;
28653 -- A flag that controls the output of a freezing-related error (see use
28656 Refined_States_Seen
: Elist_Id
:= No_Elist
;
28657 -- A list that contains all refined states processed so far. The list is
28658 -- used to detect duplicate refinements.
28660 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
28661 -- Perform full analysis of a single refinement clause
28663 procedure Report_Unrefined_States
(States
: Elist_Id
);
28664 -- Emit errors for all unrefined abstract states found in list States
28666 -------------------------------
28667 -- Analyze_Refinement_Clause --
28668 -------------------------------
28670 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
28671 AR_Constit
: Entity_Id
:= Empty
;
28672 AW_Constit
: Entity_Id
:= Empty
;
28673 ER_Constit
: Entity_Id
:= Empty
;
28674 EW_Constit
: Entity_Id
:= Empty
;
28675 -- The entities of external constituents that contain one of the
28676 -- following enabled properties: Async_Readers, Async_Writers,
28677 -- Effective_Reads and Effective_Writes.
28679 External_Constit_Seen
: Boolean := False;
28680 -- Flag used to mark when at least one external constituent is part
28681 -- of the state refinement.
28683 Non_Null_Seen
: Boolean := False;
28684 Null_Seen
: Boolean := False;
28685 -- Flags used to detect multiple uses of null in a single clause or a
28686 -- mixture of null and non-null constituents.
28688 Part_Of_Constits
: Elist_Id
:= No_Elist
;
28689 -- A list of all candidate constituents subject to indicator Part_Of
28690 -- where the encapsulating state is the current state.
28693 State_Id
: Entity_Id
;
28694 -- The current state being refined
28696 procedure Analyze_Constituent
(Constit
: Node_Id
);
28697 -- Perform full analysis of a single constituent
28699 procedure Check_External_Property
28700 (Prop_Nam
: Name_Id
;
28702 Constit
: Entity_Id
);
28703 -- Determine whether a property denoted by name Prop_Nam is present
28704 -- in the refined state. Emit an error if this is not the case. Flag
28705 -- Enabled should be set when the property applies to the refined
28706 -- state. Constit denotes the constituent (if any) which introduces
28707 -- the property in the refinement.
28709 procedure Match_State
;
28710 -- Determine whether the state being refined appears in list
28711 -- Available_States. Emit an error when attempting to re-refine the
28712 -- state or when the state is not defined in the package declaration,
28713 -- otherwise remove the state from Available_States.
28715 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
28716 -- Emit errors for all unused Part_Of constituents in list Constits
28718 -------------------------
28719 -- Analyze_Constituent --
28720 -------------------------
28722 procedure Analyze_Constituent
(Constit
: Node_Id
) is
28723 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
28724 -- Determine whether constituent Constit denoted by its entity
28725 -- Constit_Id appears in Body_States. Emit an error when the
28726 -- constituent is not a valid hidden state of the related package
28727 -- or when it is used more than once. Otherwise remove the
28728 -- constituent from Body_States.
28730 -----------------------
28731 -- Match_Constituent --
28732 -----------------------
28734 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
28735 procedure Collect_Constituent
;
28736 -- Verify the legality of constituent Constit_Id and add it to
28737 -- the refinements of State_Id.
28739 -------------------------
28740 -- Collect_Constituent --
28741 -------------------------
28743 procedure Collect_Constituent
is
28744 Constits
: Elist_Id
;
28747 -- The Ghost policy in effect at the point of abstract state
28748 -- declaration and constituent must match (SPARK RM 6.9(15))
28750 Check_Ghost_Refinement
28751 (State
, State_Id
, Constit
, Constit_Id
);
28753 -- A synchronized state must be refined by a synchronized
28754 -- object or another synchronized state (SPARK RM 9.6).
28756 if Is_Synchronized_State
(State_Id
)
28757 and then not Is_Synchronized_Object
(Constit_Id
)
28758 and then not Is_Synchronized_State
(Constit_Id
)
28761 ("constituent of synchronized state & must be "
28762 & "synchronized", Constit
, State_Id
);
28765 -- Add the constituent to the list of processed items to aid
28766 -- with the detection of duplicates.
28768 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
28770 -- Collect the constituent in the list of refinement items
28771 -- and establish a relation between the refined state and
28774 Constits
:= Refinement_Constituents
(State_Id
);
28776 if No
(Constits
) then
28777 Constits
:= New_Elmt_List
;
28778 Set_Refinement_Constituents
(State_Id
, Constits
);
28781 Append_Elmt
(Constit_Id
, Constits
);
28782 Set_Encapsulating_State
(Constit_Id
, State_Id
);
28784 -- The state has at least one legal constituent, mark the
28785 -- start of the refinement region. The region ends when the
28786 -- body declarations end (see routine Analyze_Declarations).
28788 Set_Has_Visible_Refinement
(State_Id
);
28790 -- When the constituent is external, save its relevant
28791 -- property for further checks.
28793 if Async_Readers_Enabled
(Constit_Id
) then
28794 AR_Constit
:= Constit_Id
;
28795 External_Constit_Seen
:= True;
28798 if Async_Writers_Enabled
(Constit_Id
) then
28799 AW_Constit
:= Constit_Id
;
28800 External_Constit_Seen
:= True;
28803 if Effective_Reads_Enabled
(Constit_Id
) then
28804 ER_Constit
:= Constit_Id
;
28805 External_Constit_Seen
:= True;
28808 if Effective_Writes_Enabled
(Constit_Id
) then
28809 EW_Constit
:= Constit_Id
;
28810 External_Constit_Seen
:= True;
28812 end Collect_Constituent
;
28816 State_Elmt
: Elmt_Id
;
28818 -- Start of processing for Match_Constituent
28821 -- Detect a duplicate use of a constituent
28823 if Contains
(Constituents_Seen
, Constit_Id
) then
28825 ("duplicate use of constituent &", Constit
, Constit_Id
);
28829 -- The constituent is subject to a Part_Of indicator
28831 if Present
(Encapsulating_State
(Constit_Id
)) then
28832 if Encapsulating_State
(Constit_Id
) = State_Id
then
28833 Remove
(Part_Of_Constits
, Constit_Id
);
28834 Collect_Constituent
;
28836 -- The constituent is part of another state and is used
28837 -- incorrectly in the refinement of the current state.
28840 Error_Msg_Name_1
:= Chars
(State_Id
);
28842 ("& cannot act as constituent of state %",
28843 Constit
, Constit_Id
);
28845 ("\Part_Of indicator specifies encapsulator &",
28846 Constit
, Encapsulating_State
(Constit_Id
));
28851 Pack_Id
: Entity_Id
;
28852 Placement
: State_Space_Kind
;
28854 -- Find where the constituent lives with respect to the
28857 Find_Placement_In_State_Space
28858 (Item_Id
=> Constit_Id
,
28859 Placement
=> Placement
,
28860 Pack_Id
=> Pack_Id
);
28862 -- The constituent is either part of the hidden state of
28863 -- the package or part of the visible state of a private
28864 -- child package, but lacks a Part_Of indicator.
28866 if (Placement
= Private_State_Space
28867 and then Pack_Id
= Spec_Id
)
28869 (Placement
= Visible_State_Space
28870 and then Is_Child_Unit
(Pack_Id
)
28871 and then not Is_Generic_Unit
(Pack_Id
)
28872 and then Is_Private_Descendant
(Pack_Id
))
28874 Error_Msg_Name_1
:= Chars
(State_Id
);
28876 ("& cannot act as constituent of state %",
28877 Constit
, Constit_Id
);
28879 Sloc
(Enclosing_Declaration
(Constit_Id
));
28881 ("\missing Part_Of indicator # should specify "
28882 & "encapsulator &",
28883 Constit
, State_Id
);
28885 -- The only other source of legal constituents is the
28886 -- body state space of the related package.
28889 if Present
(Body_States
) then
28890 State_Elmt
:= First_Elmt
(Body_States
);
28891 while Present
(State_Elmt
) loop
28893 -- Consume a valid constituent to signal that it
28894 -- has been encountered.
28896 if Node
(State_Elmt
) = Constit_Id
then
28897 Remove_Elmt
(Body_States
, State_Elmt
);
28898 Collect_Constituent
;
28902 Next_Elmt
(State_Elmt
);
28906 -- At this point it is known that the constituent is
28907 -- not part of the package hidden state and cannot be
28908 -- used in a refinement (SPARK RM 7.2.2(9)).
28910 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28912 ("cannot use & in refinement, constituent is not a "
28913 & "hidden state of package %", Constit
, Constit_Id
);
28917 end Match_Constituent
;
28921 Constit_Id
: Entity_Id
;
28922 Constits
: Elist_Id
;
28924 -- Start of processing for Analyze_Constituent
28927 -- Detect multiple uses of null in a single refinement clause or a
28928 -- mixture of null and non-null constituents.
28930 if Nkind
(Constit
) = N_Null
then
28933 ("multiple null constituents not allowed", Constit
);
28935 elsif Non_Null_Seen
then
28937 ("cannot mix null and non-null constituents", Constit
);
28942 -- Collect the constituent in the list of refinement items
28944 Constits
:= Refinement_Constituents
(State_Id
);
28946 if No
(Constits
) then
28947 Constits
:= New_Elmt_List
;
28948 Set_Refinement_Constituents
(State_Id
, Constits
);
28951 Append_Elmt
(Constit
, Constits
);
28953 -- The state has at least one legal constituent, mark the
28954 -- start of the refinement region. The region ends when the
28955 -- body declarations end (see Analyze_Declarations).
28957 Set_Has_Visible_Refinement
(State_Id
);
28960 -- Non-null constituents
28963 Non_Null_Seen
:= True;
28967 ("cannot mix null and non-null constituents", Constit
);
28971 Resolve_State
(Constit
);
28973 -- Ensure that the constituent denotes a valid state or a
28974 -- whole object (SPARK RM 7.2.2(5)).
28976 if Is_Entity_Name
(Constit
) then
28977 Constit_Id
:= Entity_Of
(Constit
);
28979 -- When a constituent is declared after a subprogram body
28980 -- that caused freezing of the related contract where
28981 -- pragma Refined_State resides, the constituent appears
28982 -- undefined and carries Any_Id as its entity.
28984 -- package body Pack
28985 -- with Refined_State => (State => Constit)
28988 -- with Refined_Global => (Input => Constit)
28996 if Constit_Id
= Any_Id
then
28997 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
28999 -- Emit a specialized info message when the contract of
29000 -- the related package body was "frozen" by another body.
29001 -- Note that it is not possible to precisely identify why
29002 -- the constituent is undefined because it is not visible
29003 -- when pragma Refined_State is analyzed. This message is
29004 -- a reasonable approximation.
29006 if Present
(Freeze_Id
) and then not Freeze_Posted
then
29007 Freeze_Posted
:= True;
29009 Error_Msg_Name_1
:= Chars
(Body_Id
);
29010 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
29012 ("body & declared # freezes the contract of %",
29015 ("\all constituents must be declared before body #",
29018 -- A misplaced constituent is a critical error because
29019 -- pragma Refined_Depends or Refined_Global depends on
29020 -- the proper link between a state and a constituent.
29021 -- Stop the compilation, as this leads to a multitude
29022 -- of misleading cascaded errors.
29024 raise Unrecoverable_Error
;
29027 -- The constituent is a valid state or object
29029 elsif Ekind
(Constit_Id
) in
29030 E_Abstract_State | E_Constant | E_Variable
29032 Match_Constituent
(Constit_Id
);
29034 -- The variable may eventually become a constituent of a
29035 -- single protected/task type. Record the reference now
29036 -- and verify its legality when analyzing the contract of
29037 -- the variable (SPARK RM 9.3).
29039 if Ekind
(Constit_Id
) = E_Variable
then
29040 Record_Possible_Part_Of_Reference
29041 (Var_Id
=> Constit_Id
,
29045 -- Otherwise the constituent is illegal
29049 ("constituent & must denote object or state",
29050 Constit
, Constit_Id
);
29053 -- The constituent is illegal
29056 SPARK_Msg_N
("malformed constituent", Constit
);
29059 end Analyze_Constituent
;
29061 -----------------------------
29062 -- Check_External_Property --
29063 -----------------------------
29065 procedure Check_External_Property
29066 (Prop_Nam
: Name_Id
;
29068 Constit
: Entity_Id
)
29071 -- The property is missing in the declaration of the state, but
29072 -- a constituent is introducing it in the state refinement
29073 -- (SPARK RM 7.2.8(2)).
29075 if not Enabled
and then Present
(Constit
) then
29076 Error_Msg_Name_1
:= Prop_Nam
;
29077 Error_Msg_Name_2
:= Chars
(State_Id
);
29079 ("constituent & introduces external property % in refinement "
29080 & "of state %", State
, Constit
);
29082 Error_Msg_Sloc
:= Sloc
(State_Id
);
29084 ("\property is missing in abstract state declaration #",
29087 end Check_External_Property
;
29093 procedure Match_State
is
29094 State_Elmt
: Elmt_Id
;
29097 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
29099 if Contains
(Refined_States_Seen
, State_Id
) then
29101 ("duplicate refinement of state &", State
, State_Id
);
29105 -- Inspect the abstract states defined in the package declaration
29106 -- looking for a match.
29108 State_Elmt
:= First_Elmt
(Available_States
);
29109 while Present
(State_Elmt
) loop
29111 -- A valid abstract state is being refined in the body. Add
29112 -- the state to the list of processed refined states to aid
29113 -- with the detection of duplicate refinements. Remove the
29114 -- state from Available_States to signal that it has already
29117 if Node
(State_Elmt
) = State_Id
then
29118 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
29119 Remove_Elmt
(Available_States
, State_Elmt
);
29123 Next_Elmt
(State_Elmt
);
29126 -- If we get here, we are refining a state that is not defined in
29127 -- the package declaration.
29129 Error_Msg_Name_1
:= Chars
(Spec_Id
);
29131 ("cannot refine state, & is not defined in package %",
29135 --------------------------------
29136 -- Report_Unused_Constituents --
29137 --------------------------------
29139 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
29140 Constit_Elmt
: Elmt_Id
;
29141 Constit_Id
: Entity_Id
;
29142 Posted
: Boolean := False;
29145 if Present
(Constits
) then
29146 Constit_Elmt
:= First_Elmt
(Constits
);
29147 while Present
(Constit_Elmt
) loop
29148 Constit_Id
:= Node
(Constit_Elmt
);
29150 -- Generate an error message of the form:
29152 -- state ... has unused Part_Of constituents
29153 -- abstract state ... defined at ...
29154 -- constant ... defined at ...
29155 -- variable ... defined at ...
29160 ("state & has unused Part_Of constituents",
29164 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
29166 if Ekind
(Constit_Id
) = E_Abstract_State
then
29168 ("\abstract state & defined #", State
, Constit_Id
);
29170 elsif Ekind
(Constit_Id
) = E_Constant
then
29172 ("\constant & defined #", State
, Constit_Id
);
29175 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
29176 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
29179 Next_Elmt
(Constit_Elmt
);
29182 end Report_Unused_Constituents
;
29184 -- Local declarations
29186 Body_Ref
: Node_Id
;
29187 Body_Ref_Elmt
: Elmt_Id
;
29189 Extra_State
: Node_Id
;
29191 -- Start of processing for Analyze_Refinement_Clause
29194 -- A refinement clause appears as a component association where the
29195 -- sole choice is the state and the expressions are the constituents.
29196 -- This is a syntax error, always report.
29198 if Nkind
(Clause
) /= N_Component_Association
then
29199 Error_Msg_N
("malformed state refinement clause", Clause
);
29203 -- Analyze the state name of a refinement clause
29205 State
:= First
(Choices
(Clause
));
29208 Resolve_State
(State
);
29210 -- Ensure that the state name denotes a valid abstract state that is
29211 -- defined in the spec of the related package.
29213 if Is_Entity_Name
(State
) then
29214 State_Id
:= Entity_Of
(State
);
29216 -- When the abstract state is undefined, it appears as Any_Id. Do
29217 -- not continue with the analysis of the clause.
29219 if State_Id
= Any_Id
then
29222 -- Catch any attempts to re-refine a state or refine a state that
29223 -- is not defined in the package declaration.
29225 elsif Ekind
(State_Id
) = E_Abstract_State
then
29229 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
29233 -- References to a state with visible refinement are illegal.
29234 -- When nested packages are involved, detecting such references is
29235 -- tricky because pragma Refined_State is analyzed later than the
29236 -- offending pragma Depends or Global. References that occur in
29237 -- such nested context are stored in a list. Emit errors for all
29238 -- references found in Body_References (SPARK RM 6.1.4(8)).
29240 if Present
(Body_References
(State_Id
)) then
29241 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
29242 while Present
(Body_Ref_Elmt
) loop
29243 Body_Ref
:= Node
(Body_Ref_Elmt
);
29245 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
29246 Error_Msg_Sloc
:= Sloc
(State
);
29247 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
29249 Next_Elmt
(Body_Ref_Elmt
);
29253 -- The state name is illegal. This is a syntax error, always report.
29256 Error_Msg_N
("malformed state name in refinement clause", State
);
29260 -- A refinement clause may only refine one state at a time
29262 Extra_State
:= Next
(State
);
29264 if Present
(Extra_State
) then
29266 ("refinement clause cannot cover multiple states", Extra_State
);
29269 -- Replicate the Part_Of constituents of the refined state because
29270 -- the algorithm will consume items.
29272 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
29274 -- Analyze all constituents of the refinement. Multiple constituents
29275 -- appear as an aggregate.
29277 Constit
:= Expression
(Clause
);
29279 if Nkind
(Constit
) = N_Aggregate
then
29280 if Present
(Component_Associations
(Constit
)) then
29282 ("constituents of refinement clause must appear in "
29283 & "positional form", Constit
);
29285 else pragma Assert
(Present
(Expressions
(Constit
)));
29286 Constit
:= First
(Expressions
(Constit
));
29287 while Present
(Constit
) loop
29288 Analyze_Constituent
(Constit
);
29293 -- Various forms of a single constituent. Note that these may include
29294 -- malformed constituents.
29297 Analyze_Constituent
(Constit
);
29300 -- Verify that external constituents do not introduce new external
29301 -- property in the state refinement (SPARK RM 7.2.8(2)).
29303 if Is_External_State
(State_Id
) then
29304 Check_External_Property
29305 (Prop_Nam
=> Name_Async_Readers
,
29306 Enabled
=> Async_Readers_Enabled
(State_Id
),
29307 Constit
=> AR_Constit
);
29309 Check_External_Property
29310 (Prop_Nam
=> Name_Async_Writers
,
29311 Enabled
=> Async_Writers_Enabled
(State_Id
),
29312 Constit
=> AW_Constit
);
29314 Check_External_Property
29315 (Prop_Nam
=> Name_Effective_Reads
,
29316 Enabled
=> Effective_Reads_Enabled
(State_Id
),
29317 Constit
=> ER_Constit
);
29319 Check_External_Property
29320 (Prop_Nam
=> Name_Effective_Writes
,
29321 Enabled
=> Effective_Writes_Enabled
(State_Id
),
29322 Constit
=> EW_Constit
);
29324 -- When a refined state is not external, it should not have external
29325 -- constituents (SPARK RM 7.2.8(1)).
29327 elsif External_Constit_Seen
then
29329 ("non-external state & cannot contain external constituents in "
29330 & "refinement", State
, State_Id
);
29333 -- Ensure that all Part_Of candidate constituents have been mentioned
29334 -- in the refinement clause.
29336 Report_Unused_Constituents
(Part_Of_Constits
);
29338 -- Avoid a cascading error reporting a missing refinement by adding a
29339 -- dummy constituent.
29341 if No
(Refinement_Constituents
(State_Id
)) then
29342 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
(Any_Id
));
29345 -- At this point the refinement might be dummy, but must be
29346 -- well-formed, to prevent cascaded errors.
29348 pragma Assert
(Has_Null_Refinement
(State_Id
)
29350 Has_Non_Null_Refinement
(State_Id
));
29351 end Analyze_Refinement_Clause
;
29353 -----------------------------
29354 -- Report_Unrefined_States --
29355 -----------------------------
29357 procedure Report_Unrefined_States
(States
: Elist_Id
) is
29358 State_Elmt
: Elmt_Id
;
29361 if Present
(States
) then
29362 State_Elmt
:= First_Elmt
(States
);
29363 while Present
(State_Elmt
) loop
29365 ("abstract state & must be refined", Node
(State_Elmt
));
29367 Next_Elmt
(State_Elmt
);
29370 end Report_Unrefined_States
;
29372 -- Local declarations
29374 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
29377 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29380 -- Do not analyze the pragma multiple times
29382 if Is_Analyzed_Pragma
(N
) then
29386 -- Save the scenario for examination by the ABE Processing phase
29388 Record_Elaboration_Scenario
(N
);
29390 -- Replicate the abstract states declared by the package because the
29391 -- matching algorithm will consume states.
29393 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
29395 -- Gather all abstract states and objects declared in the visible
29396 -- state space of the package body. These items must be utilized as
29397 -- constituents in a state refinement.
29399 Body_States
:= Collect_Body_States
(Body_Id
);
29401 -- Multiple non-null state refinements appear as an aggregate
29403 if Nkind
(Clauses
) = N_Aggregate
then
29404 if Present
(Expressions
(Clauses
)) then
29406 ("state refinements must appear as component associations",
29409 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
29410 Clause
:= First
(Component_Associations
(Clauses
));
29411 while Present
(Clause
) loop
29412 Analyze_Refinement_Clause
(Clause
);
29417 -- Various forms of a single state refinement. Note that these may
29418 -- include malformed refinements.
29421 Analyze_Refinement_Clause
(Clauses
);
29424 -- List all abstract states that were left unrefined
29426 Report_Unrefined_States
(Available_States
);
29428 Set_Is_Analyzed_Pragma
(N
);
29429 end Analyze_Refined_State_In_Decl_Part
;
29431 ---------------------------------------------
29432 -- Analyze_Subprogram_Variant_In_Decl_Part --
29433 ---------------------------------------------
29435 -- WARNING: This routine manages Ghost regions. Return statements must be
29436 -- replaced by gotos which jump to the end of the routine and restore the
29439 procedure Analyze_Subprogram_Variant_In_Decl_Part
29441 Freeze_Id
: Entity_Id
:= Empty
)
29443 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29444 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29446 procedure Analyze_Variant
(Variant
: Node_Id
);
29447 -- Verify the legality of a single contract case
29449 ---------------------
29450 -- Analyze_Variant --
29451 ---------------------
29453 procedure Analyze_Variant
(Variant
: Node_Id
) is
29454 Direction
: Node_Id
;
29457 Extra_Direction
: Node_Id
;
29460 if Nkind
(Variant
) /= N_Component_Association
then
29461 Error_Msg_N
("wrong syntax in subprogram variant", Variant
);
29465 Direction
:= First
(Choices
(Variant
));
29466 Expr
:= Expression
(Variant
);
29468 -- Each variant must have exactly one direction
29470 Extra_Direction
:= Next
(Direction
);
29472 if Present
(Extra_Direction
) then
29474 ("subprogram variant case must have exactly one direction",
29478 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29480 if Nkind
(Direction
) = N_Identifier
then
29481 if Chars
(Direction
) not in Name_Decreases
29485 Error_Msg_N
("wrong direction", Direction
);
29488 Error_Msg_N
("wrong syntax", Direction
);
29491 Errors
:= Serious_Errors_Detected
;
29493 -- Preanalyze_Assert_Expression, but without enforcing any of the two
29494 -- acceptable types.
29496 Preanalyze_Assert_Expression
(Expr
);
29498 -- Expression of a discrete type is allowed. Nothing more to check
29499 -- for structural variants.
29501 if Is_Discrete_Type
(Etype
(Expr
))
29502 or else Chars
(Direction
) = Name_Structural
29506 -- Expression of a Big_Integer type (or its ghost variant) is only
29507 -- allowed in Decreases clause.
29510 Is_RTE
(Base_Type
(Etype
(Expr
)), RE_Big_Integer
)
29512 Is_RTE
(Base_Type
(Etype
(Expr
)), RO_GH_Big_Integer
)
29514 if Chars
(Direction
) = Name_Increases
then
29516 ("Subprogram_Variant with Big_Integer can only decrease",
29520 -- Expression of other types is not allowed
29523 Error_Msg_N
("expected a discrete or Big_Integer type", Expr
);
29526 -- Emit a clarification message when the variant expression
29527 -- contains at least one undefined reference, possibly due
29528 -- to contract freezing.
29530 if Errors
/= Serious_Errors_Detected
29531 and then Present
(Freeze_Id
)
29532 and then Has_Undefined_Reference
(Expr
)
29534 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
29536 end Analyze_Variant
;
29540 Variants
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
29542 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
29543 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
29544 -- Save the Ghost-related attributes to restore on exit
29547 Restore_Scope
: Boolean := False;
29549 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29552 -- Do not analyze the pragma multiple times
29554 if Is_Analyzed_Pragma
(N
) then
29558 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29559 -- analysis of the pragma, the Ghost mode at point of declaration and
29560 -- point of analysis may not necessarily be the same. Use the mode in
29561 -- effect at the point of declaration.
29563 Set_Ghost_Mode
(N
);
29565 -- Single and multiple contract cases must appear in aggregate form. If
29566 -- this is not the case, then either the parser of the analysis of the
29567 -- pragma failed to produce an aggregate, e.g. when the contract is
29568 -- "null" or a "(null record)".
29571 (if Nkind
(Variants
) = N_Aggregate
29572 then Null_Record_Present
(Variants
)
29573 xor (Present
(Component_Associations
(Variants
))
29575 Present
(Expressions
(Variants
)))
29576 else Nkind
(Variants
) = N_Null
);
29578 -- Only "change_direction => discrete_expression" clauses are allowed
29580 if Nkind
(Variants
) = N_Aggregate
29581 and then Present
(Component_Associations
(Variants
))
29582 and then No
(Expressions
(Variants
))
29585 -- Check that the expression is a proper aggregate (no parentheses)
29587 if Paren_Count
(Variants
) /= 0 then
29588 Error_Msg_F
-- CODEFIX
29589 ("redundant parentheses", Variants
);
29592 -- Ensure that the formal parameters are visible when analyzing all
29593 -- clauses. This falls out of the general rule of aspects pertaining
29594 -- to subprogram declarations.
29596 if not In_Open_Scopes
(Spec_Id
) then
29597 Restore_Scope
:= True;
29598 Push_Scope
(Spec_Id
);
29600 if Is_Generic_Subprogram
(Spec_Id
) then
29601 Install_Generic_Formals
(Spec_Id
);
29603 Install_Formals
(Spec_Id
);
29607 Variant
:= First
(Component_Associations
(Variants
));
29608 while Present
(Variant
) loop
29609 Analyze_Variant
(Variant
);
29611 if Chars
(First
(Choices
(Variant
))) = Name_Structural
29612 and then List_Length
(Component_Associations
(Variants
)) > 1
29615 ("Structural variant shall be the only variant", Variant
);
29621 if Restore_Scope
then
29625 -- Otherwise the pragma is illegal
29628 Error_Msg_N
("wrong syntax for subprogram variant", N
);
29631 Set_Is_Analyzed_Pragma
(N
);
29633 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
29634 end Analyze_Subprogram_Variant_In_Decl_Part
;
29636 ------------------------------------
29637 -- Analyze_Test_Case_In_Decl_Part --
29638 ------------------------------------
29640 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
29641 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29642 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29644 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
29645 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29646 -- denoted by Arg_Nam.
29648 ------------------------------
29649 -- Preanalyze_Test_Case_Arg --
29650 ------------------------------
29652 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
29656 -- Preanalyze the original aspect argument for a generic subprogram
29657 -- to properly capture global references.
29659 if Is_Generic_Subprogram
(Spec_Id
) then
29663 Arg_Nam
=> Arg_Nam
,
29664 From_Aspect
=> True);
29666 if Present
(Arg
) then
29667 Preanalyze_Assert_Expression
29668 (Expression
(Arg
), Standard_Boolean
);
29672 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
29674 if Present
(Arg
) then
29675 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
29677 end Preanalyze_Test_Case_Arg
;
29681 Restore_Scope
: Boolean := False;
29683 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29686 -- Do not analyze the pragma multiple times
29688 if Is_Analyzed_Pragma
(N
) then
29692 -- Ensure that the formal parameters are visible when analyzing all
29693 -- clauses. This falls out of the general rule of aspects pertaining
29694 -- to subprogram declarations.
29696 if not In_Open_Scopes
(Spec_Id
) then
29697 Restore_Scope
:= True;
29698 Push_Scope
(Spec_Id
);
29700 if Is_Generic_Subprogram
(Spec_Id
) then
29701 Install_Generic_Formals
(Spec_Id
);
29703 Install_Formals
(Spec_Id
);
29707 Preanalyze_Test_Case_Arg
(Name_Requires
);
29708 Preanalyze_Test_Case_Arg
(Name_Ensures
);
29710 if Restore_Scope
then
29714 -- Currently it is not possible to inline pre/postconditions on a
29715 -- subprogram subject to pragma Inline_Always.
29717 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
29719 Set_Is_Analyzed_Pragma
(N
);
29720 end Analyze_Test_Case_In_Decl_Part
;
29726 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
29731 if Present
(List
) then
29732 Elmt
:= First_Elmt
(List
);
29733 while Present
(Elmt
) loop
29734 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
29737 Id
:= Entity_Of
(Node
(Elmt
));
29740 if Id
= Item_Id
then
29751 -----------------------------------
29752 -- Build_Pragma_Check_Equivalent --
29753 -----------------------------------
29755 function Build_Pragma_Check_Equivalent
29757 Subp_Id
: Entity_Id
:= Empty
;
29758 Inher_Id
: Entity_Id
:= Empty
;
29759 Keep_Pragma_Id
: Boolean := False) return Node_Id
29761 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
29762 -- Detect whether node N references a formal parameter subject to
29763 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29764 -- to False to suppress the generation of a reference when analyzing
29767 ------------------------
29768 -- Suppress_Reference --
29769 ------------------------
29771 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
29772 Formal
: Entity_Id
;
29775 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29776 Formal
:= Entity
(N
);
29778 -- The formal parameter is subject to pragma Unreferenced. Prevent
29779 -- the generation of references by resetting the Comes_From_Source
29782 if Is_Formal
(Formal
)
29783 and then Has_Pragma_Unreferenced
(Formal
)
29785 Set_Comes_From_Source
(N
, False);
29790 end Suppress_Reference
;
29792 procedure Suppress_References
is
29793 new Traverse_Proc
(Suppress_Reference
);
29797 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
29798 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29799 Check_Prag
: Node_Id
;
29803 -- Start of processing for Build_Pragma_Check_Equivalent
29806 -- When the pre- or postcondition is inherited, map the formals of the
29807 -- inherited subprogram to those of the current subprogram. In addition,
29808 -- map primitive operations of the parent type into the corresponding
29809 -- primitive operations of the descendant.
29811 if Present
(Inher_Id
) then
29812 pragma Assert
(Present
(Subp_Id
));
29814 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
29816 -- Use generic machinery to copy inherited pragma, as if it were an
29817 -- instantiation, resetting source locations appropriately, so that
29818 -- expressions inside the inherited pragma use chained locations.
29819 -- This is used in particular in GNATprove to locate precisely
29820 -- messages on a given inherited pragma.
29822 Set_Copied_Sloc_For_Inherited_Pragma
29823 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
29824 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29826 -- Build the inherited class-wide condition
29828 Build_Class_Wide_Expression
29829 (Pragma_Or_Expr
=> Check_Prag
,
29831 Par_Subp
=> Inher_Id
,
29832 Adjust_Sloc
=> True);
29834 -- If not an inherited condition simply copy the original pragma
29837 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29840 -- Mark the pragma as being internally generated and reset the Analyzed
29843 Set_Analyzed
(Check_Prag
, False);
29844 Set_Comes_From_Source
(Check_Prag
, False);
29846 -- The tree of the original pragma may contain references to the
29847 -- formal parameters of the related subprogram. At the same time
29848 -- the corresponding body may mark the formals as unreferenced:
29850 -- procedure Proc (Formal : ...)
29851 -- with Pre => Formal ...;
29853 -- procedure Proc (Formal : ...) is
29854 -- pragma Unreferenced (Formal);
29857 -- This creates problems because all pragma Check equivalents are
29858 -- analyzed at the end of the body declarations. Since all source
29859 -- references have already been accounted for, reset any references
29860 -- to such formals in the generated pragma Check equivalent.
29862 Suppress_References
(Check_Prag
);
29864 if Present
(Corresponding_Aspect
(Prag
)) then
29865 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
29870 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29871 -- the copied pragma in the newly created pragma, convert the copy into
29872 -- pragma Check by correcting the name and adding a check_kind argument.
29874 if not Keep_Pragma_Id
then
29875 Set_Class_Present
(Check_Prag
, False);
29877 Set_Pragma_Identifier
29878 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
29880 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
29881 Make_Pragma_Argument_Association
(Loc
,
29882 Expression
=> Make_Identifier
(Loc
, Nam
)));
29885 -- Update the error message when the pragma is inherited
29887 if Present
(Inher_Id
) then
29888 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
29890 if Chars
(Msg_Arg
) = Name_Message
then
29891 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
29893 -- Insert "inherited" to improve the error message
29895 if Name_Buffer
(1 .. 8) = "failed p" then
29896 Insert_Str_In_Name_Buffer
("inherited ", 8);
29897 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
29903 end Build_Pragma_Check_Equivalent
;
29905 -----------------------------
29906 -- Check_Applicable_Policy --
29907 -----------------------------
29909 procedure Check_Applicable_Policy
(N
: Node_Id
) is
29913 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
29916 -- No effect if not valid assertion kind name
29918 if not Is_Valid_Assertion_Kind
(Ename
) then
29922 -- Loop through entries in check policy list
29924 PP
:= Opt
.Check_Policy_List
;
29925 while Present
(PP
) loop
29927 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29928 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29932 or else Pnm
= Name_Assertion
29933 or else (Pnm
= Name_Statement_Assertions
29934 and then Ename
in Name_Assert
29935 | Name_Assert_And_Cut
29937 | Name_Loop_Invariant
29938 | Name_Loop_Variant
)
29940 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
29946 -- In CodePeer mode and GNATprove mode, we need to
29947 -- consider all assertions, unless they are disabled.
29948 -- Force Is_Checked on ignored assertions, in particular
29949 -- because transformations of the AST may depend on
29950 -- assertions being checked (e.g. the translation of
29951 -- attribute 'Loop_Entry).
29953 if CodePeer_Mode
or GNATprove_Mode
then
29954 Set_Is_Checked
(N
, True);
29955 Set_Is_Ignored
(N
, False);
29957 Set_Is_Checked
(N
, False);
29958 Set_Is_Ignored
(N
, True);
29964 Set_Is_Checked
(N
, True);
29965 Set_Is_Ignored
(N
, False);
29967 when Name_Disable
=>
29968 Set_Is_Ignored
(N
, True);
29969 Set_Is_Checked
(N
, False);
29970 Set_Is_Disabled
(N
, True);
29972 -- That should be exhaustive, the null here is a defence
29973 -- against a malformed tree from previous errors.
29982 PP
:= Next_Pragma
(PP
);
29986 -- If there are no specific entries that matched, then we let the
29987 -- setting of assertions govern. Note that this provides the needed
29988 -- compatibility with the RM for the cases of assertion, invariant,
29989 -- precondition, predicate, and postcondition. Note also that
29990 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29992 if Assertions_Enabled
then
29993 Set_Is_Checked
(N
, True);
29994 Set_Is_Ignored
(N
, False);
29996 Set_Is_Checked
(N
, False);
29997 Set_Is_Ignored
(N
, True);
29999 end Check_Applicable_Policy
;
30001 -------------------------------
30002 -- Check_External_Properties --
30003 -------------------------------
30005 procedure Check_External_Properties
30012 type Properties
is array (Positive range 1 .. 4) of Boolean;
30013 type Combinations
is array (Positive range <>) of Properties
;
30014 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
30015 -- Effective_Reads properties and their combinations, respectively.
30017 Specified
: constant Properties
:= (AR
, AW
, EW
, ER
);
30018 -- External properties, as given by the Item pragma
30020 Allowed
: constant Combinations
:=
30021 (1 => (True, False, True, False),
30022 2 => (False, True, False, True),
30023 3 => (True, False, False, False),
30024 4 => (False, True, False, False),
30025 5 => (True, True, True, False),
30026 6 => (True, True, False, True),
30027 7 => (True, True, False, False),
30028 8 => (True, True, True, True));
30029 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
30032 -- Check if the specified properties match any of the allowed
30033 -- combination; if not, then emit an error.
30035 for J
in Allowed
'Range loop
30036 if Specified
= Allowed
(J
) then
30042 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
30044 end Check_External_Properties
;
30050 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
30054 -- Loop through entries in check policy list
30056 PP
:= Opt
.Check_Policy_List
;
30057 while Present
(PP
) loop
30059 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
30060 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
30064 or else (Pnm
= Name_Assertion
30065 and then Is_Valid_Assertion_Kind
(Nam
))
30066 or else (Pnm
= Name_Statement_Assertions
30067 and then Nam
in Name_Assert
30068 | Name_Assert_And_Cut
30070 | Name_Loop_Invariant
30071 | Name_Loop_Variant
)
30073 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
30082 return Name_Ignore
;
30084 when Name_Disable
=>
30085 return Name_Disable
;
30088 raise Program_Error
;
30092 PP
:= Next_Pragma
(PP
);
30097 -- If there are no specific entries that matched, then we let the
30098 -- setting of assertions govern. Note that this provides the needed
30099 -- compatibility with the RM for the cases of assertion, invariant,
30100 -- precondition, predicate, and postcondition.
30102 if Assertions_Enabled
then
30105 return Name_Ignore
;
30109 ---------------------------
30110 -- Check_Missing_Part_Of --
30111 ---------------------------
30113 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
30114 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
30115 -- Determine whether a package denoted by Pack_Id declares at least one
30118 -----------------------
30119 -- Has_Visible_State --
30120 -----------------------
30122 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
30123 Item_Id
: Entity_Id
;
30126 -- Traverse the entity chain of the package trying to find at least
30127 -- one visible abstract state, variable or a package [instantiation]
30128 -- that declares a visible state.
30130 Item_Id
:= First_Entity
(Pack_Id
);
30131 while Present
(Item_Id
)
30132 and then not In_Private_Part
(Item_Id
)
30134 -- Do not consider internally generated items
30136 if not Comes_From_Source
(Item_Id
) then
30139 -- Do not consider generic formals or their corresponding actuals
30140 -- because they are not part of a visible state. Note that both
30141 -- entities are marked as hidden.
30143 elsif Is_Hidden
(Item_Id
) then
30146 -- A visible state has been found. Note that constants are not
30147 -- considered here because it is not possible to determine whether
30148 -- they depend on variable input. This check is left to the SPARK
30151 elsif Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
30154 -- Recursively peek into nested packages and instantiations
30156 elsif Ekind
(Item_Id
) = E_Package
30157 and then Has_Visible_State
(Item_Id
)
30162 Next_Entity
(Item_Id
);
30166 end Has_Visible_State
;
30170 Pack_Id
: Entity_Id
;
30171 Placement
: State_Space_Kind
;
30173 -- Start of processing for Check_Missing_Part_Of
30176 -- Do not consider abstract states, variables or package instantiations
30177 -- coming from an instance as those always inherit the Part_Of indicator
30178 -- of the instance itself.
30180 if In_Instance
then
30183 -- Do not consider internally generated entities as these can never
30184 -- have a Part_Of indicator.
30186 elsif not Comes_From_Source
(Item_Id
) then
30189 -- Perform these checks only when SPARK_Mode is enabled as they will
30190 -- interfere with standard Ada rules and produce false positives.
30192 elsif SPARK_Mode
/= On
then
30195 -- Do not consider constants, because the compiler cannot accurately
30196 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
30197 -- act as a hidden state of a package.
30199 elsif Ekind
(Item_Id
) = E_Constant
then
30203 -- Find where the abstract state, variable or package instantiation
30204 -- lives with respect to the state space.
30206 Find_Placement_In_State_Space
30207 (Item_Id
=> Item_Id
,
30208 Placement
=> Placement
,
30209 Pack_Id
=> Pack_Id
);
30211 -- Items that appear in a non-package construct (subprogram, block, etc)
30212 -- do not require a Part_Of indicator because they can never act as a
30215 if Placement
= Not_In_Package
then
30218 -- An item declared in the body state space of a package always act as a
30219 -- constituent and does not need explicit Part_Of indicator.
30221 elsif Placement
= Body_State_Space
then
30224 -- In general an item declared in the visible state space of a package
30225 -- does not require a Part_Of indicator. The only exception is when the
30226 -- related package is a nongeneric private child unit, in which case
30227 -- Part_Of must denote a state in the parent unit or in one of its
30230 elsif Placement
= Visible_State_Space
then
30231 if Is_Child_Unit
(Pack_Id
)
30232 and then not Is_Generic_Unit
(Pack_Id
)
30233 and then Is_Private_Descendant
(Pack_Id
)
30235 -- A package instantiation does not need a Part_Of indicator when
30236 -- the related generic template has no visible state.
30238 if Ekind
(Item_Id
) = E_Package
30239 and then Is_Generic_Instance
(Item_Id
)
30240 and then not Has_Visible_State
(Item_Id
)
30244 -- All other cases require Part_Of
30248 ("indicator Part_Of is required in this context "
30249 & "(SPARK RM 7.2.6(3))", Item_Id
);
30250 Error_Msg_Name_1
:= Chars
(Pack_Id
);
30252 ("\& is declared in the visible part of private child "
30253 & "unit %", Item_Id
);
30257 -- When the item appears in the private state space of a package, it
30258 -- must be a part of some state declared by the said package.
30260 else pragma Assert
(Placement
= Private_State_Space
);
30262 -- The related package does not declare a state, the item cannot act
30263 -- as a Part_Of constituent.
30265 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
30268 -- A package instantiation does not need a Part_Of indicator when the
30269 -- related generic template has no visible state.
30271 elsif Ekind
(Item_Id
) = E_Package
30272 and then Is_Generic_Instance
(Item_Id
)
30273 and then not Has_Visible_State
(Item_Id
)
30277 -- All other cases require Part_Of
30281 ("indicator Part_Of is required in this context "
30282 & "(SPARK RM 7.2.6(2))", Item_Id
);
30283 Error_Msg_Name_1
:= Chars
(Pack_Id
);
30285 ("\& is declared in the private part of package %", Item_Id
);
30288 end Check_Missing_Part_Of
;
30290 ---------------------------------------------------
30291 -- Check_Postcondition_Use_In_Inlined_Subprogram --
30292 ---------------------------------------------------
30294 procedure Check_Postcondition_Use_In_Inlined_Subprogram
30296 Spec_Id
: Entity_Id
)
30299 if Warn_On_Redundant_Constructs
30300 and then Has_Pragma_Inline_Always
(Spec_Id
)
30301 and then Assertions_Enabled
30303 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30305 if From_Aspect_Specification
(Prag
) then
30307 ("aspect % not enforced on inlined subprogram &?r?",
30308 Corresponding_Aspect
(Prag
), Spec_Id
);
30311 ("pragma % not enforced on inlined subprogram &?r?",
30315 end Check_Postcondition_Use_In_Inlined_Subprogram
;
30317 -------------------------------------
30318 -- Check_State_And_Constituent_Use --
30319 -------------------------------------
30321 procedure Check_State_And_Constituent_Use
30322 (States
: Elist_Id
;
30323 Constits
: Elist_Id
;
30326 Constit_Elmt
: Elmt_Id
;
30327 Constit_Id
: Entity_Id
;
30328 State_Id
: Entity_Id
;
30331 -- Nothing to do if there are no states or constituents
30333 if No
(States
) or else No
(Constits
) then
30337 -- Inspect the list of constituents and try to determine whether its
30338 -- encapsulating state is in list States.
30340 Constit_Elmt
:= First_Elmt
(Constits
);
30341 while Present
(Constit_Elmt
) loop
30342 Constit_Id
:= Node
(Constit_Elmt
);
30344 -- Determine whether the constituent is part of an encapsulating
30345 -- state that appears in the same context and if this is the case,
30346 -- emit an error (SPARK RM 7.2.6(7)).
30348 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
30350 if Present
(State_Id
) then
30351 Error_Msg_Name_1
:= Chars
(Constit_Id
);
30353 ("cannot mention state & and its constituent % in the same "
30354 & "context", Context
, State_Id
);
30358 Next_Elmt
(Constit_Elmt
);
30360 end Check_State_And_Constituent_Use
;
30362 ---------------------------------------------
30363 -- Collect_Inherited_Class_Wide_Conditions --
30364 ---------------------------------------------
30366 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
30367 Parent_Subp
: constant Entity_Id
:=
30368 Ultimate_Alias
(Overridden_Operation
(Subp
));
30369 -- The Overridden_Operation may itself be inherited and as such have no
30370 -- explicit contract.
30372 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
30373 In_Spec_Expr
: Boolean := In_Spec_Expression
;
30374 Installed
: Boolean;
30376 New_Prag
: Node_Id
;
30379 Installed
:= False;
30381 -- Iterate over the contract of the overridden subprogram to find all
30382 -- inherited class-wide pre- and postconditions.
30384 if Present
(Prags
) then
30385 Prag
:= Pre_Post_Conditions
(Prags
);
30387 while Present
(Prag
) loop
30388 if Pragma_Name_Unmapped
(Prag
)
30389 in Name_Precondition | Name_Postcondition
30390 and then Class_Present
(Prag
)
30392 -- The generated pragma must be analyzed in the context of
30393 -- the subprogram, to make its formals visible. In addition,
30394 -- we must inhibit freezing and full analysis because the
30395 -- controlling type of the subprogram is not frozen yet, and
30396 -- may have further primitives.
30398 if not Installed
then
30401 Install_Formals
(Subp
);
30402 In_Spec_Expr
:= In_Spec_Expression
;
30403 In_Spec_Expression
:= True;
30407 Build_Pragma_Check_Equivalent
30408 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
30410 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
30411 Preanalyze
(New_Prag
);
30413 -- Prevent further analysis in subsequent processing of the
30414 -- current list of declarations
30416 Set_Analyzed
(New_Prag
);
30419 Prag
:= Next_Pragma
(Prag
);
30423 In_Spec_Expression
:= In_Spec_Expr
;
30427 end Collect_Inherited_Class_Wide_Conditions
;
30429 ---------------------------------------
30430 -- Collect_Subprogram_Inputs_Outputs --
30431 ---------------------------------------
30433 procedure Collect_Subprogram_Inputs_Outputs
30434 (Subp_Id
: Entity_Id
;
30435 Synthesize
: Boolean := False;
30436 Subp_Inputs
: in out Elist_Id
;
30437 Subp_Outputs
: in out Elist_Id
;
30438 Global_Seen
: out Boolean)
30440 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
30441 -- Collect all relevant items from a dependency clause
30443 procedure Collect_Global_List
30445 Mode
: Name_Id
:= Name_Input
);
30446 -- Collect all relevant items from a global list
30448 -------------------------------
30449 -- Collect_Dependency_Clause --
30450 -------------------------------
30452 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
30453 procedure Collect_Dependency_Item
30455 Is_Input
: Boolean);
30456 -- Add an item to the proper subprogram input or output collection
30458 -----------------------------
30459 -- Collect_Dependency_Item --
30460 -----------------------------
30462 procedure Collect_Dependency_Item
30464 Is_Input
: Boolean)
30469 -- Nothing to collect when the item is null
30471 if Nkind
(Item
) = N_Null
then
30474 -- Ditto for attribute 'Result
30476 elsif Is_Attribute_Result
(Item
) then
30479 -- Multiple items appear as an aggregate
30481 elsif Nkind
(Item
) = N_Aggregate
then
30482 Extra
:= First
(Expressions
(Item
));
30483 while Present
(Extra
) loop
30484 Collect_Dependency_Item
(Extra
, Is_Input
);
30488 -- Otherwise this is a solitary item
30492 Append_New_Elmt
(Item
, Subp_Inputs
);
30494 Append_New_Elmt
(Item
, Subp_Outputs
);
30497 end Collect_Dependency_Item
;
30499 -- Start of processing for Collect_Dependency_Clause
30502 if Nkind
(Clause
) = N_Null
then
30505 -- A dependency clause appears as component association
30507 elsif Nkind
(Clause
) = N_Component_Association
then
30508 Collect_Dependency_Item
30509 (Item
=> Expression
(Clause
),
30512 Collect_Dependency_Item
30513 (Item
=> First
(Choices
(Clause
)),
30514 Is_Input
=> False);
30516 -- To accommodate partial decoration of disabled SPARK features, this
30517 -- routine may be called with illegal input. If this is the case, do
30518 -- not raise Program_Error.
30523 end Collect_Dependency_Clause
;
30525 -------------------------
30526 -- Collect_Global_List --
30527 -------------------------
30529 procedure Collect_Global_List
30531 Mode
: Name_Id
:= Name_Input
)
30533 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
30534 -- Add an item to the proper subprogram input or output collection
30536 -------------------------
30537 -- Collect_Global_Item --
30538 -------------------------
30540 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
30542 if Mode
in Name_In_Out | Name_Input
then
30543 Append_New_Elmt
(Item
, Subp_Inputs
);
30546 if Mode
in Name_In_Out | Name_Output
then
30547 Append_New_Elmt
(Item
, Subp_Outputs
);
30549 end Collect_Global_Item
;
30556 -- Start of processing for Collect_Global_List
30559 if Nkind
(List
) = N_Null
then
30562 -- Single global item declaration
30564 elsif Nkind
(List
) in N_Expanded_Name
30566 | N_Selected_Component
30568 Collect_Global_Item
(List
, Mode
);
30570 -- Simple global list or moded global list declaration
30572 elsif Nkind
(List
) = N_Aggregate
then
30573 if Present
(Expressions
(List
)) then
30574 Item
:= First
(Expressions
(List
));
30575 while Present
(Item
) loop
30576 Collect_Global_Item
(Item
, Mode
);
30581 Assoc
:= First
(Component_Associations
(List
));
30582 while Present
(Assoc
) loop
30583 Collect_Global_List
30584 (List
=> Expression
(Assoc
),
30585 Mode
=> Chars
(First
(Choices
(Assoc
))));
30590 -- To accommodate partial decoration of disabled SPARK features, this
30591 -- routine may be called with illegal input. If this is the case, do
30592 -- not raise Program_Error.
30597 end Collect_Global_List
;
30604 Formal
: Entity_Id
;
30606 Spec_Id
: Entity_Id
:= Empty
;
30607 Subp_Decl
: Node_Id
;
30610 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30613 Global_Seen
:= False;
30615 -- Process all formal parameters of entries, [generic] subprograms, and
30618 if Ekind
(Subp_Id
) in E_Entry
30621 | E_Generic_Function
30622 | E_Generic_Procedure
30624 | E_Subprogram_Body
30626 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
30627 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30629 -- Process all formal parameters
30631 Formal
:= First_Formal
(Spec_Id
);
30632 while Present
(Formal
) loop
30633 if Ekind
(Formal
) in E_In_Out_Parameter | E_In_Parameter
then
30634 Append_New_Elmt
(Formal
, Subp_Inputs
);
30637 if Ekind
(Formal
) in E_In_Out_Parameter | E_Out_Parameter
then
30638 Append_New_Elmt
(Formal
, Subp_Outputs
);
30640 -- OUT parameters can act as inputs when the related type is
30641 -- tagged, unconstrained array, unconstrained record, or record
30642 -- with unconstrained components.
30644 if Ekind
(Formal
) = E_Out_Parameter
30645 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
30647 Append_New_Elmt
(Formal
, Subp_Inputs
);
30651 -- IN parameters of procedures and protected entries can act as
30652 -- outputs when the related type is access-to-variable.
30654 if Ekind
(Formal
) = E_In_Parameter
30655 and then Ekind
(Spec_Id
) not in E_Function
30656 | E_Generic_Function
30657 and then Is_Access_Variable
(Etype
(Formal
))
30659 Append_New_Elmt
(Formal
, Subp_Outputs
);
30662 Next_Formal
(Formal
);
30665 -- Otherwise the input denotes a task type, a task body, or the
30666 -- anonymous object created for a single task type.
30668 elsif Ekind
(Subp_Id
) in E_Task_Type | E_Task_Body
30669 or else Is_Single_Task_Object
(Subp_Id
)
30671 Subp_Decl
:= Declaration_Node
(Subp_Id
);
30672 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30675 -- When processing an entry, subprogram or task body, look for pragmas
30676 -- Refined_Depends and Refined_Global as they specify the inputs and
30679 if Is_Entry_Body
(Subp_Id
)
30680 or else Ekind
(Subp_Id
) in E_Subprogram_Body | E_Task_Body
30682 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
30683 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
30685 -- Subprogram declaration or stand-alone body case, look for pragmas
30686 -- Depends and Global.
30689 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
30690 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
30693 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30694 -- because it provides finer granularity of inputs and outputs.
30696 if Present
(Global
) then
30697 Global_Seen
:= True;
30698 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
30700 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30701 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30702 -- the inputs and outputs from [Refined_]Depends.
30704 elsif Synthesize
and then Present
(Depends
) then
30705 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
30707 -- Multiple dependency clauses appear as an aggregate
30709 if Nkind
(Clauses
) = N_Aggregate
then
30710 Clause
:= First
(Component_Associations
(Clauses
));
30711 while Present
(Clause
) loop
30712 Collect_Dependency_Clause
(Clause
);
30716 -- Otherwise this is a single dependency clause
30719 Collect_Dependency_Clause
(Clauses
);
30723 -- The current instance of a protected type acts as a formal parameter
30724 -- of mode IN for functions and IN OUT for entries and procedures
30725 -- (SPARK RM 6.1.4).
30727 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
30728 Typ
:= Scope
(Spec_Id
);
30730 -- Use the anonymous object when the type is single protected
30732 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30733 Typ
:= Anonymous_Object
(Typ
);
30736 Append_New_Elmt
(Typ
, Subp_Inputs
);
30738 if Ekind
(Spec_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
30739 Append_New_Elmt
(Typ
, Subp_Outputs
);
30742 -- The current instance of a task type acts as a formal parameter of
30743 -- mode IN OUT (SPARK RM 6.1.4).
30745 elsif Ekind
(Spec_Id
) = E_Task_Type
then
30748 -- Use the anonymous object when the type is single task
30750 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30751 Typ
:= Anonymous_Object
(Typ
);
30754 Append_New_Elmt
(Typ
, Subp_Inputs
);
30755 Append_New_Elmt
(Typ
, Subp_Outputs
);
30757 elsif Is_Single_Task_Object
(Spec_Id
) then
30758 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
30759 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
30761 end Collect_Subprogram_Inputs_Outputs
;
30763 ---------------------------
30764 -- Contract_Freeze_Error --
30765 ---------------------------
30767 procedure Contract_Freeze_Error
30768 (Contract_Id
: Entity_Id
;
30769 Freeze_Id
: Entity_Id
)
30772 Error_Msg_Name_1
:= Chars
(Contract_Id
);
30773 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30776 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
30778 ("\all contractual items must be declared before body #", Contract_Id
);
30779 end Contract_Freeze_Error
;
30781 ---------------------------------
30782 -- Delay_Config_Pragma_Analyze --
30783 ---------------------------------
30785 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
30787 return Pragma_Name_Unmapped
(N
)
30788 in Name_Interrupt_State | Name_Priority_Specific_Dispatching
;
30789 end Delay_Config_Pragma_Analyze
;
30791 -----------------------
30792 -- Duplication_Error --
30793 -----------------------
30795 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
30796 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
30797 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
30800 Error_Msg_Sloc
:= Sloc
(Prev
);
30801 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30803 -- Emit a precise message to distinguish between source pragmas and
30804 -- pragmas generated from aspects. The ordering of the two pragmas is
30808 -- Prag -- duplicate
30810 -- No error is emitted when both pragmas come from aspects because this
30811 -- is already detected by the general aspect analysis mechanism.
30813 if Prag_From_Asp
and Prev_From_Asp
then
30815 elsif Prag_From_Asp
then
30816 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
30817 elsif Prev_From_Asp
then
30818 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
30820 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
30822 end Duplication_Error
;
30824 ------------------------------
30825 -- Find_Encapsulating_State --
30826 ------------------------------
30828 function Find_Encapsulating_State
30829 (States
: Elist_Id
;
30830 Constit_Id
: Entity_Id
) return Entity_Id
30832 State_Id
: Entity_Id
;
30835 -- Since a constituent may be part of a larger constituent set, climb
30836 -- the encapsulating state chain looking for a state that appears in
30839 State_Id
:= Encapsulating_State
(Constit_Id
);
30840 while Present
(State_Id
) loop
30841 if Contains
(States
, State_Id
) then
30845 State_Id
:= Encapsulating_State
(State_Id
);
30849 end Find_Encapsulating_State
;
30851 --------------------------
30852 -- Find_Related_Context --
30853 --------------------------
30855 function Find_Related_Context
30857 Do_Checks
: Boolean := False) return Node_Id
30862 -- If the pragma comes from an aspect on a compilation unit that is a
30863 -- package instance, then return the original package instantiation
30866 if Nkind
(Parent
(Prag
)) = N_Compilation_Unit_Aux
then
30868 Get_Unit_Instantiation_Node
30869 (Defining_Entity
(Unit
(Enclosing_Comp_Unit_Node
(Prag
))));
30872 Stmt
:= Prev
(Prag
);
30873 while Present
(Stmt
) loop
30875 -- Skip prior pragmas, but check for duplicates
30877 if Nkind
(Stmt
) = N_Pragma
then
30879 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
30886 -- Skip internally generated code
30888 elsif not Comes_From_Source
(Stmt
)
30889 and then not Comes_From_Source
(Original_Node
(Stmt
))
30892 -- The anonymous object created for a single concurrent type is a
30893 -- suitable context.
30895 if Nkind
(Stmt
) = N_Object_Declaration
30896 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30901 -- Return the current source construct
30911 end Find_Related_Context
;
30913 --------------------------------------
30914 -- Find_Related_Declaration_Or_Body --
30915 --------------------------------------
30917 function Find_Related_Declaration_Or_Body
30919 Do_Checks
: Boolean := False) return Node_Id
30921 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
30923 procedure Expression_Function_Error
;
30924 -- Emit an error concerning pragma Prag that illegaly applies to an
30925 -- expression function.
30927 -------------------------------
30928 -- Expression_Function_Error --
30929 -------------------------------
30931 procedure Expression_Function_Error
is
30933 Error_Msg_Name_1
:= Prag_Nam
;
30935 -- Emit a precise message to distinguish between source pragmas and
30936 -- pragmas generated from aspects.
30938 if From_Aspect_Specification
(Prag
) then
30940 ("aspect % cannot apply to a standalone expression function",
30944 ("pragma % cannot apply to a standalone expression function",
30947 end Expression_Function_Error
;
30951 Context
: constant Node_Id
:= Parent
(Prag
);
30954 Look_For_Body
: constant Boolean :=
30955 Prag_Nam
in Name_Refined_Depends
30956 | Name_Refined_Global
30957 | Name_Refined_Post
30958 | Name_Refined_State
;
30959 -- Refinement pragmas must be associated with a subprogram body [stub]
30961 -- Start of processing for Find_Related_Declaration_Or_Body
30964 Stmt
:= Prev
(Prag
);
30965 while Present
(Stmt
) loop
30967 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30968 -- by splitting a complex pre/postcondition are not considered to
30971 if Nkind
(Stmt
) = N_Pragma
then
30973 and then not Split_PPC
(Stmt
)
30974 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
30981 -- Emit an error when a refinement pragma appears on an expression
30982 -- function without a completion.
30985 and then Look_For_Body
30986 and then Nkind
(Stmt
) = N_Subprogram_Declaration
30987 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
30988 and then not Has_Completion
(Defining_Entity
(Stmt
))
30990 Expression_Function_Error
;
30993 -- The refinement pragma applies to a subprogram body stub
30995 elsif Look_For_Body
30996 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
31000 -- Skip internally generated code
31002 elsif not Comes_From_Source
(Stmt
) then
31004 -- The anonymous object created for a single concurrent type is a
31005 -- suitable context.
31007 if Nkind
(Stmt
) = N_Object_Declaration
31008 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
31012 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
31014 -- The subprogram declaration is an internally generated spec
31015 -- for an expression function.
31017 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
31020 -- The subprogram declaration is an internally generated spec
31021 -- for a stand-alone subprogram body declared inside a
31024 elsif Present
(Corresponding_Body
(Stmt
))
31025 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
31026 and then Is_Protected_Type
(Current_Scope
)
31030 -- The subprogram is actually an instance housed within an
31031 -- anonymous wrapper package.
31033 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
31036 -- Ada 2022: contract on formal subprogram or on generated
31037 -- Access_Subprogram_Wrapper, which appears after the related
31038 -- Access_Subprogram declaration.
31040 elsif Is_Generic_Actual_Subprogram
(Defining_Entity
(Stmt
))
31041 and then Ada_Version
>= Ada_2022
31045 elsif Is_Access_Subprogram_Wrapper
(Defining_Entity
(Stmt
))
31046 and then Ada_Version
>= Ada_2022
31052 -- Return the current construct which is either a subprogram body,
31053 -- a subprogram declaration or is illegal.
31062 -- If we fall through, then the pragma was either the first declaration
31063 -- or it was preceded by other pragmas and no source constructs.
31065 -- The pragma is associated with a library-level subprogram
31067 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
31068 return Unit
(Parent
(Context
));
31070 -- The pragma appears inside the declarations of an entry body
31072 elsif Nkind
(Context
) = N_Entry_Body
then
31075 -- The pragma appears inside the statements of a subprogram body at
31076 -- some nested level.
31078 elsif Is_Statement
(Context
)
31079 and then Present
(Enclosing_HSS
(Context
))
31081 return Parent
(Enclosing_HSS
(Context
));
31083 -- The pragma appears directly in the statements of a subprogram body
31085 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
31086 return Parent
(Context
);
31088 -- The pragma appears inside the declarative part of a package body
31090 elsif Nkind
(Context
) = N_Package_Body
then
31093 -- The pragma appears inside the declarative part of a subprogram body
31095 elsif Nkind
(Context
) = N_Subprogram_Body
then
31098 -- The pragma appears inside the declarative part of a task body
31100 elsif Nkind
(Context
) = N_Task_Body
then
31103 -- The pragma appears inside the visible part of a package specification
31105 elsif Nkind
(Context
) = N_Package_Specification
then
31106 return Parent
(Context
);
31108 -- The pragma is a byproduct of aspect expansion, return the related
31109 -- context of the original aspect. This case has a lower priority as
31110 -- the above circuitry pinpoints precisely the related context.
31112 elsif Present
(Corresponding_Aspect
(Prag
)) then
31113 return Parent
(Corresponding_Aspect
(Prag
));
31115 -- No candidate subprogram [body] found
31120 end Find_Related_Declaration_Or_Body
;
31122 ----------------------------------
31123 -- Find_Related_Package_Or_Body --
31124 ----------------------------------
31126 function Find_Related_Package_Or_Body
31128 Do_Checks
: Boolean := False) return Node_Id
31130 Context
: constant Node_Id
:= Parent
(Prag
);
31131 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
31135 Stmt
:= Prev
(Prag
);
31136 while Present
(Stmt
) loop
31138 -- Skip prior pragmas, but check for duplicates
31140 if Nkind
(Stmt
) = N_Pragma
then
31141 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
31147 -- Skip internally generated code
31149 elsif not Comes_From_Source
(Stmt
) then
31150 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
31152 -- The subprogram declaration is an internally generated spec
31153 -- for an expression function.
31155 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
31158 -- The subprogram is actually an instance housed within an
31159 -- anonymous wrapper package.
31161 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
31166 -- Return the current source construct which is illegal
31175 -- If we fall through, then the pragma was either the first declaration
31176 -- or it was preceded by other pragmas and no source constructs.
31178 -- The pragma is associated with a package. The immediate context in
31179 -- this case is the specification of the package.
31181 if Nkind
(Context
) = N_Package_Specification
then
31182 return Parent
(Context
);
31184 -- The pragma appears in the declarations of a package body
31186 elsif Nkind
(Context
) = N_Package_Body
then
31189 -- The pragma appears in the statements of a package body
31191 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
31192 and then Nkind
(Parent
(Context
)) = N_Package_Body
31194 return Parent
(Context
);
31196 -- The pragma is a byproduct of aspect expansion, return the related
31197 -- context of the original aspect. This case has a lower priority as
31198 -- the above circuitry pinpoints precisely the related context.
31200 elsif Present
(Corresponding_Aspect
(Prag
)) then
31201 return Parent
(Corresponding_Aspect
(Prag
));
31203 -- No candidate package [body] found
31208 end Find_Related_Package_Or_Body
;
31214 function Get_Argument
31216 Context_Id
: Entity_Id
:= Empty
) return Node_Id
31218 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
31221 -- Use the expression of the original aspect when analyzing the template
31222 -- of a generic unit. In both cases the aspect's tree must be decorated
31223 -- to save the global references in the generic context.
31225 if From_Aspect_Specification
(Prag
)
31226 and then (Present
(Context_Id
) and then Is_Generic_Unit
(Context_Id
))
31228 return Corresponding_Aspect
(Prag
);
31230 -- Otherwise use the expression of the pragma
31232 elsif Present
(Args
) then
31233 return First
(Args
);
31240 -------------------------
31241 -- Get_Base_Subprogram --
31242 -------------------------
31244 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
31246 -- Follow subprogram renaming chain
31248 if Is_Subprogram
(Def_Id
)
31249 and then Parent_Kind
(Declaration_Node
(Def_Id
)) =
31250 N_Subprogram_Renaming_Declaration
31251 and then Present
(Alias
(Def_Id
))
31253 return Alias
(Def_Id
);
31257 end Get_Base_Subprogram
;
31259 -------------------------
31260 -- Get_SPARK_Mode_Type --
31261 -------------------------
31263 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
31273 -- Any other argument is illegal. Assume that no SPARK mode applies
31274 -- to avoid potential cascaded errors.
31279 end Get_SPARK_Mode_Type
;
31281 ------------------------------------
31282 -- Get_SPARK_Mode_From_Annotation --
31283 ------------------------------------
31285 function Get_SPARK_Mode_From_Annotation
31286 (N
: Node_Id
) return SPARK_Mode_Type
31291 if Nkind
(N
) = N_Aspect_Specification
then
31292 Mode
:= Expression
(N
);
31294 else pragma Assert
(Nkind
(N
) = N_Pragma
);
31295 Mode
:= First
(Pragma_Argument_Associations
(N
));
31297 if Present
(Mode
) then
31298 Mode
:= Get_Pragma_Arg
(Mode
);
31302 -- Aspect or pragma SPARK_Mode specifies an explicit mode
31304 if Present
(Mode
) then
31305 if Nkind
(Mode
) = N_Identifier
then
31306 return Get_SPARK_Mode_Type
(Chars
(Mode
));
31308 -- In case of a malformed aspect or pragma, return the default None
31314 -- Otherwise the lack of an expression defaults SPARK_Mode to On
31319 end Get_SPARK_Mode_From_Annotation
;
31321 ---------------------------
31322 -- Has_Extra_Parentheses --
31323 ---------------------------
31325 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
31329 -- The aggregate should not have an expression list because a clause
31330 -- is always interpreted as a component association. The only way an
31331 -- expression list can sneak in is by adding extra parentheses around
31332 -- the individual clauses:
31334 -- Depends (Output => Input) -- proper form
31335 -- Depends ((Output => Input)) -- extra parentheses
31337 -- Since the extra parentheses are not allowed by the syntax of the
31338 -- pragma, flag them now to avoid emitting misleading errors down the
31341 if Nkind
(Clause
) = N_Aggregate
31342 and then Present
(Expressions
(Clause
))
31344 Expr
:= First
(Expressions
(Clause
));
31345 while Present
(Expr
) loop
31347 -- A dependency clause surrounded by extra parentheses appears
31348 -- as an aggregate of component associations with an optional
31349 -- Paren_Count set.
31351 if Nkind
(Expr
) = N_Aggregate
31352 and then Present
(Component_Associations
(Expr
))
31355 ("dependency clause contains extra parentheses", Expr
);
31357 -- Otherwise the expression is a malformed construct
31360 SPARK_Msg_N
("malformed dependency clause", Expr
);
31370 end Has_Extra_Parentheses
;
31376 procedure Initialize
is
31379 Compile_Time_Warnings_Errors
.Init
;
31388 Dummy
:= Dummy
+ 1;
31391 -----------------------------
31392 -- Is_Config_Static_String --
31393 -----------------------------
31395 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
31397 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
31398 -- This is an internal recursive function that is just like the outer
31399 -- function except that it adds the string to the name buffer rather
31400 -- than placing the string in the name buffer.
31402 ------------------------------
31403 -- Add_Config_Static_String --
31404 ------------------------------
31406 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
31413 if Nkind
(N
) = N_Op_Concat
then
31414 if Add_Config_Static_String
(Left_Opnd
(N
)) then
31415 N
:= Right_Opnd
(N
);
31421 if Nkind
(N
) /= N_String_Literal
then
31422 Error_Msg_N
("string literal expected for pragma argument", N
);
31426 for J
in 1 .. String_Length
(Strval
(N
)) loop
31427 C
:= Get_String_Char
(Strval
(N
), J
);
31429 if not In_Character_Range
(C
) then
31431 ("string literal contains invalid wide character",
31432 Sloc
(N
) + 1 + Source_Ptr
(J
));
31436 Add_Char_To_Name_Buffer
(Get_Character
(C
));
31441 end Add_Config_Static_String
;
31443 -- Start of processing for Is_Config_Static_String
31448 return Add_Config_Static_String
(Arg
);
31449 end Is_Config_Static_String
;
31451 -------------------------------
31452 -- Is_Elaboration_SPARK_Mode --
31453 -------------------------------
31455 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
31458 (Nkind
(N
) = N_Pragma
31459 and then Pragma_Name
(N
) = Name_SPARK_Mode
31460 and then Is_List_Member
(N
));
31462 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31463 -- appears in the statement part of the body.
31466 Present
(Parent
(N
))
31467 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
31468 and then List_Containing
(N
) = Statements
(Parent
(N
))
31469 and then Present
(Parent
(Parent
(N
)))
31470 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
31471 end Is_Elaboration_SPARK_Mode
;
31473 -----------------------
31474 -- Is_Enabled_Pragma --
31475 -----------------------
31477 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
31481 if Present
(Prag
) then
31482 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
31484 if Present
(Arg
) then
31485 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
31487 -- The lack of a Boolean argument automatically enables the pragma
31493 -- The pragma is missing, therefore it is not enabled
31498 end Is_Enabled_Pragma
;
31500 -----------------------------------------
31501 -- Is_Non_Significant_Pragma_Reference --
31502 -----------------------------------------
31504 -- This function makes use of the following static table which indicates
31505 -- whether appearance of some name in a given pragma is to be considered
31506 -- as a reference for the purposes of warnings about unreferenced objects.
31508 -- -1 indicates that appearance in any argument is significant
31509 -- 0 indicates that appearance in any argument is not significant
31510 -- +n indicates that appearance as argument n is significant, but all
31511 -- other arguments are not significant
31512 -- 9n arguments from n on are significant, before n insignificant
31514 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
31515 (Pragma_Abort_Defer
=> -1,
31516 Pragma_Abstract_State
=> -1,
31517 Pragma_Ada_83
=> -1,
31518 Pragma_Ada_95
=> -1,
31519 Pragma_Ada_05
=> -1,
31520 Pragma_Ada_2005
=> -1,
31521 Pragma_Ada_12
=> -1,
31522 Pragma_Ada_2012
=> -1,
31523 Pragma_Ada_2022
=> -1,
31524 Pragma_Aggregate_Individually_Assign
=> 0,
31525 Pragma_All_Calls_Remote
=> -1,
31526 Pragma_Allow_Integer_Address
=> -1,
31527 Pragma_Annotate
=> 93,
31528 Pragma_Assert
=> -1,
31529 Pragma_Assert_And_Cut
=> -1,
31530 Pragma_Assertion_Policy
=> 0,
31531 Pragma_Assume
=> -1,
31532 Pragma_Assume_No_Invalid_Values
=> 0,
31533 Pragma_Async_Readers
=> 0,
31534 Pragma_Async_Writers
=> 0,
31535 Pragma_Asynchronous
=> 0,
31536 Pragma_Atomic
=> 0,
31537 Pragma_Atomic_Components
=> 0,
31538 Pragma_Attach_Handler
=> -1,
31539 Pragma_Attribute_Definition
=> 92,
31540 Pragma_Check
=> -1,
31541 Pragma_Check_Float_Overflow
=> 0,
31542 Pragma_Check_Name
=> 0,
31543 Pragma_Check_Policy
=> 0,
31544 Pragma_CPP_Class
=> 0,
31545 Pragma_CPP_Constructor
=> 0,
31546 Pragma_CPP_Virtual
=> 0,
31547 Pragma_CPP_Vtable
=> 0,
31549 Pragma_C_Pass_By_Copy
=> 0,
31550 Pragma_Comment
=> -1,
31551 Pragma_Common_Object
=> 0,
31552 Pragma_CUDA_Device
=> -1,
31553 Pragma_CUDA_Execute
=> -1,
31554 Pragma_CUDA_Global
=> -1,
31555 Pragma_Compile_Time_Error
=> -1,
31556 Pragma_Compile_Time_Warning
=> -1,
31557 Pragma_Complete_Representation
=> 0,
31558 Pragma_Complex_Representation
=> 0,
31559 Pragma_Component_Alignment
=> 0,
31560 Pragma_Constant_After_Elaboration
=> 0,
31561 Pragma_Contract_Cases
=> -1,
31562 Pragma_Controlled
=> 0,
31563 Pragma_Convention
=> 0,
31564 Pragma_Convention_Identifier
=> 0,
31565 Pragma_Deadline_Floor
=> -1,
31566 Pragma_Debug
=> -1,
31567 Pragma_Debug_Policy
=> 0,
31568 Pragma_Default_Initial_Condition
=> -1,
31569 Pragma_Default_Scalar_Storage_Order
=> 0,
31570 Pragma_Default_Storage_Pool
=> 0,
31571 Pragma_Depends
=> -1,
31572 Pragma_Detect_Blocking
=> 0,
31573 Pragma_Disable_Atomic_Synchronization
=> 0,
31574 Pragma_Discard_Names
=> 0,
31575 Pragma_Dispatching_Domain
=> -1,
31576 Pragma_Effective_Reads
=> 0,
31577 Pragma_Effective_Writes
=> 0,
31578 Pragma_Elaborate
=> 0,
31579 Pragma_Elaborate_All
=> 0,
31580 Pragma_Elaborate_Body
=> 0,
31581 Pragma_Elaboration_Checks
=> 0,
31582 Pragma_Eliminate
=> 0,
31583 Pragma_Enable_Atomic_Synchronization
=> 0,
31584 Pragma_Export
=> -1,
31585 Pragma_Export_Function
=> -1,
31586 Pragma_Export_Object
=> -1,
31587 Pragma_Export_Procedure
=> -1,
31588 Pragma_Export_Valued_Procedure
=> -1,
31589 Pragma_Extend_System
=> -1,
31590 Pragma_Extensions_Allowed
=> 0,
31591 Pragma_Extensions_Visible
=> 0,
31592 Pragma_External
=> -1,
31593 Pragma_External_Name_Casing
=> 0,
31594 Pragma_Fast_Math
=> 0,
31595 Pragma_Favor_Top_Level
=> 0,
31596 Pragma_Finalize_Storage_Only
=> 0,
31598 Pragma_Global
=> -1,
31599 Pragma_GNAT_Annotate
=> 93,
31600 Pragma_Ident
=> -1,
31601 Pragma_Ignore_Pragma
=> 0,
31602 Pragma_Implementation_Defined
=> -1,
31603 Pragma_Implemented
=> -1,
31604 Pragma_Implicit_Packing
=> 0,
31605 Pragma_Import
=> 93,
31606 Pragma_Import_Function
=> 0,
31607 Pragma_Import_Object
=> 0,
31608 Pragma_Import_Procedure
=> 0,
31609 Pragma_Import_Valued_Procedure
=> 0,
31610 Pragma_Independent
=> 0,
31611 Pragma_Independent_Components
=> 0,
31612 Pragma_Initial_Condition
=> -1,
31613 Pragma_Initialize_Scalars
=> 0,
31614 Pragma_Initializes
=> -1,
31615 Pragma_Inline
=> 0,
31616 Pragma_Inline_Always
=> 0,
31617 Pragma_Inline_Generic
=> 0,
31618 Pragma_Inspection_Point
=> -1,
31619 Pragma_Interface
=> 92,
31620 Pragma_Interface_Name
=> 0,
31621 Pragma_Interrupt_Handler
=> -1,
31622 Pragma_Interrupt_Priority
=> -1,
31623 Pragma_Interrupt_State
=> -1,
31624 Pragma_Invariant
=> -1,
31625 Pragma_Keep_Names
=> 0,
31626 Pragma_License
=> 0,
31627 Pragma_Link_With
=> -1,
31628 Pragma_Linker_Alias
=> -1,
31629 Pragma_Linker_Constructor
=> -1,
31630 Pragma_Linker_Destructor
=> -1,
31631 Pragma_Linker_Options
=> -1,
31632 Pragma_Linker_Section
=> -1,
31634 Pragma_Lock_Free
=> 0,
31635 Pragma_Locking_Policy
=> 0,
31636 Pragma_Loop_Invariant
=> -1,
31637 Pragma_Loop_Optimize
=> 0,
31638 Pragma_Loop_Variant
=> -1,
31639 Pragma_Machine_Attribute
=> -1,
31641 Pragma_Main_Storage
=> -1,
31642 Pragma_Max_Entry_Queue_Depth
=> 0,
31643 Pragma_Max_Entry_Queue_Length
=> 0,
31644 Pragma_Max_Queue_Length
=> 0,
31645 Pragma_Memory_Size
=> 0,
31646 Pragma_No_Body
=> 0,
31647 Pragma_No_Caching
=> 0,
31648 Pragma_No_Component_Reordering
=> -1,
31649 Pragma_No_Elaboration_Code_All
=> 0,
31650 Pragma_No_Heap_Finalization
=> 0,
31651 Pragma_No_Inline
=> 0,
31652 Pragma_No_Return
=> 0,
31653 Pragma_No_Run_Time
=> -1,
31654 Pragma_No_Strict_Aliasing
=> -1,
31655 Pragma_No_Tagged_Streams
=> 0,
31656 Pragma_Normalize_Scalars
=> 0,
31657 Pragma_Obsolescent
=> 0,
31658 Pragma_Optimize
=> 0,
31659 Pragma_Optimize_Alignment
=> 0,
31660 Pragma_Ordered
=> 0,
31661 Pragma_Overflow_Mode
=> 0,
31662 Pragma_Overriding_Renamings
=> 0,
31665 Pragma_Part_Of
=> 0,
31666 Pragma_Partition_Elaboration_Policy
=> 0,
31667 Pragma_Passive
=> 0,
31668 Pragma_Persistent_BSS
=> 0,
31670 Pragma_Postcondition
=> -1,
31671 Pragma_Post_Class
=> -1,
31673 Pragma_Precondition
=> -1,
31674 Pragma_Predicate
=> -1,
31675 Pragma_Predicate_Failure
=> -1,
31676 Pragma_Preelaborable_Initialization
=> -1,
31677 Pragma_Preelaborate
=> 0,
31678 Pragma_Prefix_Exception_Messages
=> 0,
31679 Pragma_Pre_Class
=> -1,
31680 Pragma_Priority
=> -1,
31681 Pragma_Priority_Specific_Dispatching
=> 0,
31682 Pragma_Profile
=> 0,
31683 Pragma_Profile_Warnings
=> 0,
31684 Pragma_Propagate_Exceptions
=> 0,
31685 Pragma_Provide_Shift_Operators
=> 0,
31686 Pragma_Psect_Object
=> 0,
31688 Pragma_Pure_Function
=> 0,
31689 Pragma_Queuing_Policy
=> 0,
31690 Pragma_Rational
=> 0,
31691 Pragma_Ravenscar
=> 0,
31692 Pragma_Refined_Depends
=> -1,
31693 Pragma_Refined_Global
=> -1,
31694 Pragma_Refined_Post
=> -1,
31695 Pragma_Refined_State
=> 0,
31696 Pragma_Relative_Deadline
=> 0,
31697 Pragma_Remote_Access_Type
=> -1,
31698 Pragma_Remote_Call_Interface
=> -1,
31699 Pragma_Remote_Types
=> -1,
31700 Pragma_Rename_Pragma
=> 0,
31701 Pragma_Restricted_Run_Time
=> 0,
31702 Pragma_Restriction_Warnings
=> 0,
31703 Pragma_Restrictions
=> 0,
31704 Pragma_Reviewable
=> -1,
31705 Pragma_Secondary_Stack_Size
=> -1,
31706 Pragma_Share_Generic
=> 0,
31707 Pragma_Shared
=> 0,
31708 Pragma_Shared_Passive
=> 0,
31709 Pragma_Short_Circuit_And_Or
=> 0,
31710 Pragma_Short_Descriptors
=> 0,
31711 Pragma_Simple_Storage_Pool_Type
=> 0,
31712 Pragma_Source_File_Name
=> 0,
31713 Pragma_Source_File_Name_Project
=> 0,
31714 Pragma_Source_Reference
=> 0,
31715 Pragma_SPARK_Mode
=> 0,
31716 Pragma_Static_Elaboration_Desired
=> 0,
31717 Pragma_Storage_Size
=> -1,
31718 Pragma_Storage_Unit
=> 0,
31719 Pragma_Stream_Convert
=> 0,
31720 Pragma_Style_Checks
=> 0,
31721 Pragma_Subprogram_Variant
=> -1,
31722 Pragma_Subtitle
=> 0,
31723 Pragma_Suppress
=> 0,
31724 Pragma_Suppress_All
=> 0,
31725 Pragma_Suppress_Debug_Info
=> 0,
31726 Pragma_Suppress_Exception_Locations
=> 0,
31727 Pragma_Suppress_Initialization
=> 0,
31728 Pragma_System_Name
=> 0,
31729 Pragma_Task_Dispatching_Policy
=> 0,
31730 Pragma_Task_Info
=> -1,
31731 Pragma_Task_Name
=> -1,
31732 Pragma_Task_Storage
=> -1,
31733 Pragma_Test_Case
=> -1,
31734 Pragma_Thread_Local_Storage
=> -1,
31735 Pragma_Time_Slice
=> -1,
31737 Pragma_Type_Invariant
=> -1,
31738 Pragma_Type_Invariant_Class
=> -1,
31739 Pragma_Unchecked_Union
=> 0,
31740 Pragma_Unevaluated_Use_Of_Old
=> 0,
31741 Pragma_Unimplemented_Unit
=> 0,
31742 Pragma_Universal_Aliasing
=> 0,
31743 Pragma_Unmodified
=> 0,
31744 Pragma_Unreferenced
=> 0,
31745 Pragma_Unreferenced_Objects
=> 0,
31746 Pragma_Unreserve_All_Interrupts
=> 0,
31747 Pragma_Unsuppress
=> 0,
31748 Pragma_Unused
=> 0,
31749 Pragma_Use_VADS_Size
=> 0,
31750 Pragma_Validity_Checks
=> 0,
31751 Pragma_Volatile
=> 0,
31752 Pragma_Volatile_Components
=> 0,
31753 Pragma_Volatile_Full_Access
=> 0,
31754 Pragma_Volatile_Function
=> 0,
31755 Pragma_Warning_As_Error
=> 0,
31756 Pragma_Warnings
=> 0,
31757 Pragma_Weak_External
=> 0,
31758 Pragma_Wide_Character_Encoding
=> 0,
31759 Unknown_Pragma
=> 0);
31761 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
31767 function Arg_No
return Nat
;
31768 -- Returns an integer showing what argument we are in. A value of
31769 -- zero means we are not in any of the arguments.
31775 function Arg_No
return Nat
is
31780 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
31794 -- Start of processing for Non_Significant_Pragma_Reference
31797 -- Reference might appear either directly as expression of a pragma
31798 -- argument association, e.g. pragma Export (...), or within an
31799 -- aggregate with component associations, e.g. pragma Refined_State
31805 when N_Pragma_Argument_Association
=>
31807 when N_Aggregate | N_Component_Association
=>
31820 Id
:= Get_Pragma_Id
(Parent
(P
));
31821 C
:= Sig_Flags
(Id
);
31831 return AN
< (C
- 90);
31836 end Is_Non_Significant_Pragma_Reference
;
31838 ------------------------------
31839 -- Is_Pragma_String_Literal --
31840 ------------------------------
31842 -- This function returns true if the corresponding pragma argument is a
31843 -- static string expression. These are the only cases in which string
31844 -- literals can appear as pragma arguments. We also allow a string literal
31845 -- as the first argument to pragma Assert (although it will of course
31846 -- always generate a type error).
31848 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
31849 Pragn
: constant Node_Id
:= Parent
(Par
);
31850 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
31851 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
31857 N
:= First
(Assoc
);
31864 if Pname
= Name_Assert
then
31867 elsif Pname
= Name_Export
then
31870 elsif Pname
= Name_Ident
then
31873 elsif Pname
= Name_Import
then
31876 elsif Pname
= Name_Interface_Name
then
31879 elsif Pname
= Name_Linker_Alias
then
31882 elsif Pname
= Name_Linker_Section
then
31885 elsif Pname
= Name_Machine_Attribute
then
31888 elsif Pname
= Name_Source_File_Name
then
31891 elsif Pname
= Name_Source_Reference
then
31894 elsif Pname
= Name_Title
then
31897 elsif Pname
= Name_Subtitle
then
31903 end Is_Pragma_String_Literal
;
31905 ---------------------------
31906 -- Is_Private_SPARK_Mode --
31907 ---------------------------
31909 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
31912 (Nkind
(N
) = N_Pragma
31913 and then Pragma_Name
(N
) = Name_SPARK_Mode
31914 and then Is_List_Member
(N
));
31916 -- For pragma SPARK_Mode to be private, it has to appear in the private
31917 -- declarations of a package.
31920 Present
(Parent
(N
))
31921 and then Nkind
(Parent
(N
)) = N_Package_Specification
31922 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
31923 end Is_Private_SPARK_Mode
;
31925 -------------------------------------
31926 -- Is_Unconstrained_Or_Tagged_Item --
31927 -------------------------------------
31929 function Is_Unconstrained_Or_Tagged_Item
31930 (Item
: Entity_Id
) return Boolean
31932 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
31933 -- Determine whether record type Typ has at least one unconstrained
31936 ---------------------------------
31937 -- Has_Unconstrained_Component --
31938 ---------------------------------
31940 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
31944 Comp
:= First_Component
(Typ
);
31945 while Present
(Comp
) loop
31946 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
31950 Next_Component
(Comp
);
31954 end Has_Unconstrained_Component
;
31958 Typ
: constant Entity_Id
:= Etype
(Item
);
31960 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31963 if Is_Tagged_Type
(Typ
) then
31966 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
31969 elsif Is_Record_Type
(Typ
) then
31970 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
31973 return Has_Unconstrained_Component
(Typ
);
31976 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
31982 end Is_Unconstrained_Or_Tagged_Item
;
31984 -----------------------------
31985 -- Is_Valid_Assertion_Kind --
31986 -----------------------------
31988 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
31995 | Name_Static_Predicate
31996 | Name_Dynamic_Predicate
32001 | Name_Type_Invariant
32002 | Name_uType_Invariant
32006 | Name_Assert_And_Cut
32008 | Name_Contract_Cases
32010 | Name_Default_Initial_Condition
32012 | Name_Initial_Condition
32015 | Name_Loop_Invariant
32016 | Name_Loop_Variant
32017 | Name_Postcondition
32018 | Name_Precondition
32020 | Name_Refined_Post
32021 | Name_Statement_Assertions
32022 | Name_Subprogram_Variant
32029 end Is_Valid_Assertion_Kind
;
32031 --------------------------------------
32032 -- Process_Compilation_Unit_Pragmas --
32033 --------------------------------------
32035 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
32037 -- A special check for pragma Suppress_All, a very strange DEC pragma,
32038 -- strange because it comes at the end of the unit. Rational has the
32039 -- same name for a pragma, but treats it as a program unit pragma, In
32040 -- GNAT we just decide to allow it anywhere at all. If it appeared then
32041 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
32042 -- node, and we insert a pragma Suppress (All_Checks) at the start of
32043 -- the context clause to ensure the correct processing.
32045 if Has_Pragma_Suppress_All
(N
) then
32046 Prepend_To
(Context_Items
(N
),
32047 Make_Pragma
(Sloc
(N
),
32048 Chars
=> Name_Suppress
,
32049 Pragma_Argument_Associations
=> New_List
(
32050 Make_Pragma_Argument_Association
(Sloc
(N
),
32051 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
32054 -- Nothing else to do at the current time
32056 end Process_Compilation_Unit_Pragmas
;
32058 --------------------------------------------
32059 -- Validate_Compile_Time_Warning_Or_Error --
32060 --------------------------------------------
32062 procedure Validate_Compile_Time_Warning_Or_Error
32066 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
32067 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
32068 Arg2
: constant Node_Id
:= Next
(Arg1
);
32070 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
32071 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
32074 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
32076 if Compile_Time_Known_Value
(Arg1x
) then
32077 if Is_True
(Expr_Value
(Arg1x
)) then
32079 -- We have already verified that the second argument is a static
32080 -- string expression. Its string value must be retrieved
32081 -- explicitly if it is a declared constant, otherwise it has
32082 -- been constant-folded previously.
32085 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
32086 Str
: constant String_Id
:=
32087 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
32088 Str_Len
: constant Nat
:= String_Length
(Str
);
32090 Force
: constant Boolean :=
32091 Prag_Id
= Pragma_Compile_Time_Warning
32092 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
32093 and then (Ekind
(Cent
) /= E_Package
32094 or else not In_Private_Part
(Cent
));
32095 -- Set True if this is the warning case, and we are in the
32096 -- visible part of a package spec, or in a subprogram spec,
32097 -- in which case we want to force the client to see the
32098 -- warning, even though it is not in the main unit.
32106 -- Loop through segments of message separated by line feeds.
32107 -- We output these segments as separate messages with
32108 -- continuation marks for all but the first.
32113 Error_Msg_Strlen
:= 0;
32115 -- Loop to copy characters from argument to error message
32119 exit when Ptr
> Str_Len
;
32120 CC
:= Get_String_Char
(Str
, Ptr
);
32123 -- Ignore wide chars ??? else store character
32125 if In_Character_Range
(CC
) then
32126 C
:= Get_Character
(CC
);
32127 exit when C
= ASCII
.LF
;
32128 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
32129 Error_Msg_String
(Error_Msg_Strlen
) := C
;
32133 -- Here with one line ready to go
32135 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
32137 -- If this is a warning in a spec, then we want clients
32138 -- to see the warning, so mark the message with the
32139 -- special sequence !! to force the warning. In the case
32140 -- of a package spec, we do not force this if we are in
32141 -- the private part of the spec.
32144 if Cont
= False then
32146 ("<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
32150 ("\<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
32153 -- Error, rather than warning, or in a body, so we do not
32154 -- need to force visibility for client (error will be
32155 -- output in any case, and this is the situation in which
32156 -- we do not want a client to get a warning, since the
32157 -- warning is in the body or the spec private part).
32160 if Cont
= False then
32162 ("<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
32166 ("\<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
32170 exit when Ptr
> Str_Len
;
32175 -- Arg1x is not known at compile time, so possibly issue an error
32176 -- or warning. This can happen only if the pragma's processing
32177 -- was deferred until after the back end is run (see
32178 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
32179 -- control switch applies to only the warning case.
32181 elsif Prag_Id
= Pragma_Compile_Time_Error
then
32182 Error_Msg_N
("condition is not known at compile time", Arg1x
);
32184 elsif Warn_On_Unknown_Compile_Time_Warning
then
32185 Error_Msg_N
("?_c?condition is not known at compile time", Arg1x
);
32187 end Validate_Compile_Time_Warning_Or_Error
;
32189 ------------------------------------
32190 -- Record_Possible_Body_Reference --
32191 ------------------------------------
32193 procedure Record_Possible_Body_Reference
32194 (State_Id
: Entity_Id
;
32198 Spec_Id
: Entity_Id
;
32201 -- Ensure that we are dealing with a reference to a state
32203 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
32205 -- Climb the tree starting from the reference looking for a package body
32206 -- whose spec declares the referenced state. This criteria automatically
32207 -- excludes references in package specs which are legal. Note that it is
32208 -- not wise to emit an error now as the package body may lack pragma
32209 -- Refined_State or the referenced state may not be mentioned in the
32210 -- refinement. This approach avoids the generation of misleading errors.
32213 while Present
(Context
) loop
32214 if Nkind
(Context
) = N_Package_Body
then
32215 Spec_Id
:= Corresponding_Spec
(Context
);
32217 if Present
(Abstract_States
(Spec_Id
))
32218 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
32220 if No
(Body_References
(State_Id
)) then
32221 Set_Body_References
(State_Id
, New_Elmt_List
);
32224 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
32229 Context
:= Parent
(Context
);
32231 end Record_Possible_Body_Reference
;
32233 ------------------------------------------
32234 -- Relocate_Pragmas_To_Anonymous_Object --
32235 ------------------------------------------
32237 procedure Relocate_Pragmas_To_Anonymous_Object
32238 (Typ_Decl
: Node_Id
;
32239 Obj_Decl
: Node_Id
)
32243 Next_Decl
: Node_Id
;
32246 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
32247 Def
:= Protected_Definition
(Typ_Decl
);
32249 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
32250 Def
:= Task_Definition
(Typ_Decl
);
32253 -- The concurrent definition has a visible declaration list. Inspect it
32254 -- and relocate all canidate pragmas.
32256 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
32257 Decl
:= First
(Visible_Declarations
(Def
));
32258 while Present
(Decl
) loop
32260 -- Preserve the following declaration for iteration purposes due
32261 -- to possible relocation of a pragma.
32263 Next_Decl
:= Next
(Decl
);
32265 if Nkind
(Decl
) = N_Pragma
32266 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
32269 Insert_After
(Obj_Decl
, Decl
);
32271 -- Skip internally generated code
32273 elsif not Comes_From_Source
(Decl
) then
32276 -- No candidate pragmas are available for relocation
32285 end Relocate_Pragmas_To_Anonymous_Object
;
32287 ------------------------------
32288 -- Relocate_Pragmas_To_Body --
32289 ------------------------------
32291 procedure Relocate_Pragmas_To_Body
32292 (Subp_Body
: Node_Id
;
32293 Target_Body
: Node_Id
:= Empty
)
32295 procedure Relocate_Pragma
(Prag
: Node_Id
);
32296 -- Remove a single pragma from its current list and add it to the
32297 -- declarations of the proper body (either Subp_Body or Target_Body).
32299 ---------------------
32300 -- Relocate_Pragma --
32301 ---------------------
32303 procedure Relocate_Pragma
(Prag
: Node_Id
) is
32308 -- When subprogram stubs or expression functions are involves, the
32309 -- destination declaration list belongs to the proper body.
32311 if Present
(Target_Body
) then
32312 Target
:= Target_Body
;
32314 Target
:= Subp_Body
;
32317 Decls
:= Declarations
(Target
);
32321 Set_Declarations
(Target
, Decls
);
32324 -- Unhook the pragma from its current list
32327 Prepend
(Prag
, Decls
);
32328 end Relocate_Pragma
;
32332 Body_Id
: constant Entity_Id
:=
32333 Defining_Unit_Name
(Specification
(Subp_Body
));
32334 Next_Stmt
: Node_Id
;
32337 -- Start of processing for Relocate_Pragmas_To_Body
32340 -- Do not process a body that comes from a separate unit as no construct
32341 -- can possibly follow it.
32343 if not Is_List_Member
(Subp_Body
) then
32346 -- Do not relocate pragmas that follow a stub if the stub does not have
32349 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
32350 and then No
(Target_Body
)
32354 -- Do not process internally generated routine _Wrapped_Statements
32356 elsif Ekind
(Body_Id
) = E_Procedure
32357 and then Chars
(Body_Id
) = Name_uWrapped_Statements
32362 -- Look at what is following the body. We are interested in certain kind
32363 -- of pragmas (either from source or byproducts of expansion) that can
32364 -- apply to a body [stub].
32366 Stmt
:= Next
(Subp_Body
);
32367 while Present
(Stmt
) loop
32369 -- Preserve the following statement for iteration purposes due to a
32370 -- possible relocation of a pragma.
32372 Next_Stmt
:= Next
(Stmt
);
32374 -- Move a candidate pragma following the body to the declarations of
32377 if Nkind
(Stmt
) = N_Pragma
32378 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
32381 -- If a source pragma Warnings follows the body, it applies to
32382 -- following statements and does not belong in the body.
32384 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
32385 and then Comes_From_Source
(Stmt
)
32389 Relocate_Pragma
(Stmt
);
32392 -- Skip internally generated code
32394 elsif not Comes_From_Source
(Stmt
) then
32397 -- No candidate pragmas are available for relocation
32405 end Relocate_Pragmas_To_Body
;
32407 -------------------
32408 -- Resolve_State --
32409 -------------------
32411 procedure Resolve_State
(N
: Node_Id
) is
32416 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
32417 Func
:= Entity
(N
);
32419 -- Handle overloading of state names by functions. Traverse the
32420 -- homonym chain looking for an abstract state.
32422 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
32423 pragma Assert
(Is_Overloaded
(N
));
32425 State
:= Homonym
(Func
);
32426 while Present
(State
) loop
32427 if Ekind
(State
) = E_Abstract_State
then
32429 -- Resolve the overloading by setting the proper entity of
32430 -- the reference to that of the state.
32432 Set_Etype
(N
, Standard_Void_Type
);
32433 Set_Entity
(N
, State
);
32434 Set_Is_Overloaded
(N
, False);
32436 Generate_Reference
(State
, N
);
32440 State
:= Homonym
(State
);
32443 -- A function can never act as a state. If the homonym chain does
32444 -- not contain a corresponding state, then something went wrong in
32445 -- the overloading mechanism.
32447 raise Program_Error
;
32452 ----------------------------
32453 -- Rewrite_Assertion_Kind --
32454 ----------------------------
32456 procedure Rewrite_Assertion_Kind
32458 From_Policy
: Boolean := False)
32464 if Nkind
(N
) = N_Attribute_Reference
32465 and then Attribute_Name
(N
) = Name_Class
32466 and then Nkind
(Prefix
(N
)) = N_Identifier
32468 case Chars
(Prefix
(N
)) is
32475 when Name_Type_Invariant
=>
32476 Nam
:= Name_uType_Invariant
;
32478 when Name_Invariant
=>
32479 Nam
:= Name_uInvariant
;
32485 -- Recommend standard use of aspect names Pre/Post
32487 elsif Nkind
(N
) = N_Identifier
32488 and then From_Policy
32489 and then Serious_Errors_Detected
= 0
32491 if Chars
(N
) = Name_Precondition
32492 or else Chars
(N
) = Name_Postcondition
32494 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
32496 ("\use Assertion_Policy and aspect names Pre/Post for "
32497 & "Ada2012 conformance?", N
);
32503 if Nam
/= No_Name
then
32504 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
32506 end Rewrite_Assertion_Kind
;
32514 Dummy
:= Dummy
+ 1;
32517 --------------------------------
32518 -- Set_Encoded_Interface_Name --
32519 --------------------------------
32521 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
32522 Str
: constant String_Id
:= Strval
(S
);
32523 Len
: constant Nat
:= String_Length
(Str
);
32528 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
32531 -- Stores encoded value of character code CC. The encoding we use an
32532 -- underscore followed by four lower case hex digits.
32538 procedure Encode
is
32540 Store_String_Char
(Get_Char_Code
('_'));
32542 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
32544 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
32546 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
32548 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
32551 -- Start of processing for Set_Encoded_Interface_Name
32554 -- If first character is asterisk, this is a link name, and we leave it
32555 -- completely unmodified. We also ignore null strings (the latter case
32556 -- happens only in error cases).
32559 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
32561 Set_Interface_Name
(E
, S
);
32566 CC
:= Get_String_Char
(Str
, J
);
32568 exit when not In_Character_Range
(CC
);
32570 C
:= Get_Character
(CC
);
32572 exit when C
/= '_' and then C
/= '$'
32573 and then C
not in '0' .. '9'
32574 and then C
not in 'a' .. 'z'
32575 and then C
not in 'A' .. 'Z';
32578 Set_Interface_Name
(E
, S
);
32586 -- Here we need to encode. The encoding we use as follows:
32587 -- three underscores + four hex digits (lower case)
32591 for J
in 1 .. String_Length
(Str
) loop
32592 CC
:= Get_String_Char
(Str
, J
);
32594 if not In_Character_Range
(CC
) then
32597 C
:= Get_Character
(CC
);
32599 if C
= '_' or else C
= '$'
32600 or else C
in '0' .. '9'
32601 or else C
in 'a' .. 'z'
32602 or else C
in 'A' .. 'Z'
32604 Store_String_Char
(CC
);
32611 Set_Interface_Name
(E
,
32612 Make_String_Literal
(Sloc
(S
),
32613 Strval
=> End_String
));
32615 end Set_Encoded_Interface_Name
;
32617 ------------------------
32618 -- Set_Elab_Unit_Name --
32619 ------------------------
32621 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
32626 if Nkind
(N
) = N_Identifier
32627 and then Nkind
(With_Item
) = N_Identifier
32629 Set_Entity
(N
, Entity
(With_Item
));
32631 elsif Nkind
(N
) = N_Selected_Component
then
32632 Change_Selected_Component_To_Expanded_Name
(N
);
32633 Set_Entity
(N
, Entity
(With_Item
));
32634 Set_Entity
(Selector_Name
(N
), Entity
(N
));
32636 Pref
:= Prefix
(N
);
32637 Scop
:= Scope
(Entity
(N
));
32638 while Nkind
(Pref
) = N_Selected_Component
loop
32639 Change_Selected_Component_To_Expanded_Name
(Pref
);
32640 Set_Entity
(Selector_Name
(Pref
), Scop
);
32641 Set_Entity
(Pref
, Scop
);
32642 Pref
:= Prefix
(Pref
);
32643 Scop
:= Scope
(Scop
);
32646 Set_Entity
(Pref
, Scop
);
32649 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
32650 end Set_Elab_Unit_Name
;
32652 -----------------------
32653 -- Set_Overflow_Mode --
32654 -----------------------
32656 procedure Set_Overflow_Mode
(N
: Node_Id
) is
32658 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
;
32659 -- Function to process one pragma argument, Arg
32661 -----------------------
32662 -- Get_Overflow_Mode --
32663 -----------------------
32665 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
is
32666 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
32669 if Chars
(Argx
) = Name_Strict
then
32672 elsif Chars
(Argx
) = Name_Minimized
then
32675 elsif Chars
(Argx
) = Name_Eliminated
then
32679 raise Program_Error
;
32681 end Get_Overflow_Mode
;
32685 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
32686 Arg2
: constant Node_Id
:= Next
(Arg1
);
32688 -- Start of processing for Set_Overflow_Mode
32691 -- Process first argument
32693 Scope_Suppress
.Overflow_Mode_General
:=
32694 Get_Overflow_Mode
(Arg1
);
32696 -- Case of only one argument
32699 Scope_Suppress
.Overflow_Mode_Assertions
:=
32700 Scope_Suppress
.Overflow_Mode_General
;
32702 -- Case of two arguments present
32705 Scope_Suppress
.Overflow_Mode_Assertions
:=
32706 Get_Overflow_Mode
(Arg2
);
32708 end Set_Overflow_Mode
;
32710 -------------------
32711 -- Test_Case_Arg --
32712 -------------------
32714 function Test_Case_Arg
32717 From_Aspect
: Boolean := False) return Node_Id
32719 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
32725 (Arg_Nam
in Name_Ensures | Name_Mode | Name_Name | Name_Requires
);
32727 -- The caller requests the aspect argument
32729 if From_Aspect
then
32730 if Present
(Aspect
)
32731 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
32733 Args
:= Expression
(Aspect
);
32735 -- "Name" and "Mode" may appear without an identifier as a
32736 -- positional association.
32738 if Present
(Expressions
(Args
)) then
32739 Arg
:= First
(Expressions
(Args
));
32741 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32749 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32754 -- Some or all arguments may appear as component associatons
32756 if Present
(Component_Associations
(Args
)) then
32757 Arg
:= First
(Component_Associations
(Args
));
32758 while Present
(Arg
) loop
32759 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
32768 -- Otherwise retrieve the argument directly from the pragma
32771 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32773 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32777 -- Skip argument "Name"
32781 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32785 -- Skip argument "Mode"
32789 -- Arguments "Requires" and "Ensures" are optional and may not be
32792 while Present
(Arg
) loop
32793 if Chars
(Arg
) = Arg_Nam
then
32804 --------------------------------------------
32805 -- Defer_Compile_Time_Warning_Error_To_BE --
32806 --------------------------------------------
32808 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
) is
32809 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
32811 Compile_Time_Warnings_Errors
.Append
32812 (New_Val
=> CTWE_Entry
'(Eloc => Sloc (Arg1),
32813 Scope => Current_Scope,
32816 -- If the Boolean expression contains T'Size, and we're not in the main
32817 -- unit being compiled, then we need to copy the pragma into the main
32818 -- unit, because otherwise T'Size might never be computed, leaving it
32821 if not In_Extended_Main_Code_Unit (N) then
32822 Insert_Library_Level_Action (New_Copy_Tree (N));
32824 end Defer_Compile_Time_Warning_Error_To_BE;
32826 ------------------------------------------
32827 -- Validate_Compile_Time_Warning_Errors --
32828 ------------------------------------------
32830 procedure Validate_Compile_Time_Warning_Errors is
32831 procedure Set_Scope (S : Entity_Id);
32832 -- Install all enclosing scopes of S along with S itself
32834 procedure Unset_Scope (S : Entity_Id);
32835 -- Uninstall all enclosing scopes of S along with S itself
32841 procedure Set_Scope (S : Entity_Id) is
32843 if S /= Standard_Standard then
32844 Set_Scope (Scope (S));
32854 procedure Unset_Scope (S : Entity_Id) is
32856 if S /= Standard_Standard then
32857 Unset_Scope (Scope (S));
32863 -- Start of processing for Validate_Compile_Time_Warning_Errors
32866 Expander_Mode_Save_And_Set (False);
32867 In_Compile_Time_Warning_Or_Error := True;
32869 for N in Compile_Time_Warnings_Errors.First ..
32870 Compile_Time_Warnings_Errors.Last
32873 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32876 Set_Scope (T.Scope);
32877 Reset_Analyzed_Flags (T.Prag);
32878 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32879 Unset_Scope (T.Scope);
32883 In_Compile_Time_Warning_Or_Error := False;
32884 Expander_Mode_Restore;
32885 end Validate_Compile_Time_Warning_Errors;