1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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_Ch8
; use Sem_Ch8
;
67 with Sem_Ch12
; use Sem_Ch12
;
68 with Sem_Ch13
; use Sem_Ch13
;
69 with Sem_Disp
; use Sem_Disp
;
70 with Sem_Dist
; use Sem_Dist
;
71 with Sem_Elab
; use Sem_Elab
;
72 with Sem_Elim
; use Sem_Elim
;
73 with Sem_Eval
; use Sem_Eval
;
74 with Sem_Intr
; use Sem_Intr
;
75 with Sem_Mech
; use Sem_Mech
;
76 with Sem_Res
; use Sem_Res
;
77 with Sem_Type
; use Sem_Type
;
78 with Sem_Util
; use Sem_Util
;
79 with Sem_Warn
; use Sem_Warn
;
80 with Stand
; use Stand
;
81 with Sinfo
; use Sinfo
;
82 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
83 with Sinfo
.Utils
; use Sinfo
.Utils
;
84 with Sinfo
.CN
; use Sinfo
.CN
;
85 with Sinput
; use Sinput
;
86 with Stringt
; use Stringt
;
87 with Strub
; use Strub
;
88 with Stylesw
; use Stylesw
;
90 with Targparm
; use Targparm
;
91 with Tbuild
; use Tbuild
;
93 with Uintp
; use Uintp
;
94 with Uname
; use Uname
;
95 with Urealp
; use Urealp
;
96 with Validsw
; use Validsw
;
97 with Warnsw
; use Warnsw
;
99 with System
.Case_Util
;
101 package body Sem_Prag
is
103 ----------------------------------------------
104 -- Common Handling of Import-Export Pragmas --
105 ----------------------------------------------
107 -- In the following section, a number of Import_xxx and Export_xxx pragmas
108 -- are defined by GNAT. These are compatible with the DEC pragmas of the
109 -- same name, and all have the following common form and processing:
112 -- [Internal =>] LOCAL_NAME
113 -- [, [External =>] EXTERNAL_SYMBOL]
114 -- [, other optional parameters ]);
117 -- [Internal =>] LOCAL_NAME
118 -- [, [External =>] EXTERNAL_SYMBOL]
119 -- [, other optional parameters ]);
121 -- EXTERNAL_SYMBOL ::=
123 -- | static_string_EXPRESSION
125 -- The internal LOCAL_NAME designates the entity that is imported or
126 -- exported, and must refer to an entity in the current declarative
127 -- part (as required by the rules for LOCAL_NAME).
129 -- The external linker name is designated by the External parameter if
130 -- given, or the Internal parameter if not (if there is no External
131 -- parameter, the External parameter is a copy of the Internal name).
133 -- If the External parameter is given as a string, then this string is
134 -- treated as an external name (exactly as though it had been given as an
135 -- External_Name parameter for a normal Import pragma).
137 -- If the External parameter is given as an identifier (or there is no
138 -- External parameter, so that the Internal identifier is used), then
139 -- the external name is the characters of the identifier, translated
140 -- to all lower case letters.
142 -- Note: the external name specified or implied by any of these special
143 -- Import_xxx or Export_xxx pragmas override an external or link name
144 -- specified in a previous Import or Export pragma.
146 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
147 -- named notation, following the standard rules for subprogram calls, i.e.
148 -- parameters can be given in any order if named notation is used, and
149 -- positional and named notation can be mixed, subject to the rule that all
150 -- positional parameters must appear first.
152 -- Note: All these pragmas are implemented exactly following the DEC design
153 -- and implementation and are intended to be fully compatible with the use
154 -- of these pragmas in the DEC Ada compiler.
156 --------------------------------------------
157 -- Checking for Duplicated External Names --
158 --------------------------------------------
160 -- It is suspicious if two separate Export pragmas use the same external
161 -- name. The following table is used to diagnose this situation so that
162 -- an appropriate warning can be issued.
164 -- The Node_Id stored is for the N_String_Literal node created to hold
165 -- the value of the external name. The Sloc of this node is used to
166 -- cross-reference the location of the duplication.
168 package Externals
is new Table
.Table
(
169 Table_Component_Type
=> Node_Id
,
170 Table_Index_Type
=> Int
,
171 Table_Low_Bound
=> 0,
172 Table_Initial
=> 100,
173 Table_Increment
=> 100,
174 Table_Name
=> "Name_Externals");
176 -------------------------------------
177 -- Local Subprograms and Variables --
178 -------------------------------------
180 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
181 -- This routine is used for possible casing adjustment of an explicit
182 -- external name supplied as a string literal (the node N), according to
183 -- the casing requirement of Opt.External_Name_Casing. If this is set to
184 -- As_Is, then the string literal is returned unchanged, but if it is set
185 -- to Uppercase or Lowercase, then a new string literal with appropriate
186 -- casing is constructed.
188 procedure Analyze_Part_Of
192 Encap_Id
: out Entity_Id
;
193 Legal
: out Boolean);
194 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
195 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
196 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
197 -- package instantiation. Encap denotes the encapsulating state or single
198 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
199 -- the indicator is legal.
201 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
202 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
203 -- Query whether a particular item appears in a mixed list of nodes and
204 -- entities. It is assumed that all nodes in the list have entities.
206 procedure Check_Postcondition_Use_In_Inlined_Subprogram
208 Spec_Id
: Entity_Id
);
209 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
210 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
211 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
212 -- and assertions are enabled.
214 procedure Check_State_And_Constituent_Use
218 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
219 -- Global and Initializes. Determine whether a state from list States and a
220 -- corresponding constituent from list Constits (if any) appear in the same
221 -- context denoted by Context. If this is the case, emit an error.
223 procedure Contract_Freeze_Error
224 (Contract_Id
: Entity_Id
;
225 Freeze_Id
: Entity_Id
);
226 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
227 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
228 -- of a body which caused contract freezing and Contract_Id denotes the
229 -- entity of the affected contstruct.
231 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
232 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
233 -- Prag that duplicates previous pragma Prev.
235 function Find_Encapsulating_State
237 Constit_Id
: Entity_Id
) return Entity_Id
;
238 -- Given the entity of a constituent Constit_Id, find the corresponding
239 -- encapsulating state which appears in States. The routine returns Empty
240 -- if no such state is found.
242 function Find_Related_Context
244 Do_Checks
: Boolean := False) return Node_Id
;
245 -- Subsidiary to the analysis of pragmas
248 -- Constant_After_Elaboration
253 -- Find the first source declaration or statement found while traversing
254 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
255 -- set, the routine reports duplicate pragmas. The routine returns Empty
256 -- when reaching the start of the node chain.
258 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
259 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
260 -- original one, following the renaming chain) is returned. Otherwise the
261 -- entity is returned unchanged. Should be in Einfo???
263 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
264 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
265 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
266 -- value of type SPARK_Mode_Type.
268 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
269 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
270 -- Determine whether dependency clause Clause is surrounded by extra
271 -- parentheses. If this is the case, issue an error message.
273 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
274 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
275 -- pragma Depends. Determine whether the type of dependency item Item is
276 -- tagged, unconstrained array, unconstrained record or a record with at
277 -- least one unconstrained component.
279 procedure Record_Possible_Body_Reference
280 (State_Id
: Entity_Id
;
282 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
283 -- Global. Given an abstract state denoted by State_Id and a reference Ref
284 -- to it, determine whether the reference appears in a package body that
285 -- will eventually refine the state. If this is the case, record the
286 -- reference for future checks (see Analyze_Refined_State_In_Decls).
288 procedure Resolve_State
(N
: Node_Id
);
289 -- Handle the overloading of state names by functions. When N denotes a
290 -- function, this routine finds the corresponding state and sets the entity
291 -- of N to that of the state.
293 procedure Rewrite_Assertion_Kind
295 From_Policy
: Boolean := False);
296 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
297 -- then it is rewritten as an identifier with the corresponding special
298 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
299 -- and Check_Policy. If the names are Precondition or Postcondition, this
300 -- combination is deprecated in favor of Assertion_Policy and Ada2012
301 -- Aspect names. The parameter From_Policy indicates that the pragma
302 -- is the old non-standard Check_Policy and not a rewritten pragma.
304 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
305 -- Place semantic information on the argument of an Elaborate/Elaborate_All
306 -- pragma. Entity name for unit and its parents is taken from item in
307 -- previous with_clause that mentions the unit.
309 procedure Validate_Compile_Time_Warning_Or_Error
312 -- Common processing for Compile_Time_Error and Compile_Time_Warning of
313 -- pragma N. Called when the pragma is processed as part of its regular
314 -- analysis but also called after calling the back end to validate these
315 -- pragmas for size and alignment appropriateness.
317 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
);
318 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
319 -- expression is not known at compile time during the front end. This
320 -- procedure makes an entry in a table. The actual checking is performed by
321 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the
324 Dummy
: Integer := 0;
325 pragma Volatile
(Dummy
);
326 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
329 pragma No_Inline
(ip
);
330 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
331 -- is just to help debugging the front end. If a pragma Inspection_Point
332 -- is added to a source program, then breaking on ip will get you to that
333 -- point in the program.
336 pragma No_Inline
(rv
);
337 -- This is a dummy function called by the processing for pragma Reviewable.
338 -- It is there for assisting front end debugging. By placing a Reviewable
339 -- pragma in the source program, a breakpoint on rv catches this place in
340 -- the source, allowing convenient stepping to the point of interest.
342 ------------------------------------------------------
343 -- Table for Defer_Compile_Time_Warning_Error_To_BE --
344 ------------------------------------------------------
346 -- The following table collects pragmas Compile_Time_Error and Compile_
347 -- Time_Warning for validation. Entries are made by calls to subprogram
348 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure
349 -- Validate_Compile_Time_Warning_Errors does the actual error checking
350 -- and posting of warning and error messages. The reason for this delayed
351 -- processing is to take advantage of back-annotations of attributes size
352 -- and alignment values performed by the back end.
354 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
355 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint
356 -- will already have modified all Sloc values if the -gnatD option is set.
358 type CTWE_Entry
is record
360 -- Source location used in warnings and error messages
363 -- Pragma Compile_Time_Error or Compile_Time_Warning
366 -- The scope which encloses the pragma
369 package Compile_Time_Warnings_Errors
is new Table
.Table
(
370 Table_Component_Type
=> CTWE_Entry
,
371 Table_Index_Type
=> Int
,
372 Table_Low_Bound
=> 1,
374 Table_Increment
=> 200,
375 Table_Name
=> "Compile_Time_Warnings_Errors");
377 -------------------------------
378 -- Adjust_External_Name_Case --
379 -------------------------------
381 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
385 -- Adjust case of literal if required
387 if Opt
.External_Name_Exp_Casing
= As_Is
then
391 -- Copy existing string
397 for J
in 1 .. String_Length
(Strval
(N
)) loop
398 CC
:= Get_String_Char
(Strval
(N
), J
);
400 if Opt
.External_Name_Exp_Casing
= Uppercase
401 and then CC
>= Get_Char_Code
('a')
402 and then CC
<= Get_Char_Code
('z')
404 Store_String_Char
(CC
- 32);
406 elsif Opt
.External_Name_Exp_Casing
= Lowercase
407 and then CC
>= Get_Char_Code
('A')
408 and then CC
<= Get_Char_Code
('Z')
410 Store_String_Char
(CC
+ 32);
413 Store_String_Char
(CC
);
418 Make_String_Literal
(Sloc
(N
),
419 Strval
=> End_String
);
421 end Adjust_External_Name_Case
;
423 -----------------------------------------
424 -- Analyze_Contract_Cases_In_Decl_Part --
425 -----------------------------------------
427 -- WARNING: This routine manages Ghost regions. Return statements must be
428 -- replaced by gotos which jump to the end of the routine and restore the
431 procedure Analyze_Contract_Cases_In_Decl_Part
433 Freeze_Id
: Entity_Id
:= Empty
)
435 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
436 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
438 Others_Seen
: Boolean := False;
439 -- This flag is set when an "others" choice is encountered. It is used
440 -- to detect multiple illegal occurrences of "others".
442 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
443 -- Verify the legality of a single contract case
445 ---------------------------
446 -- Analyze_Contract_Case --
447 ---------------------------
449 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
450 Case_Guard
: Node_Id
;
453 Extra_Guard
: Node_Id
;
456 if Nkind
(CCase
) = N_Component_Association
then
457 Case_Guard
:= First
(Choices
(CCase
));
458 Conseq
:= Expression
(CCase
);
460 -- Each contract case must have exactly one case guard
462 Extra_Guard
:= Next
(Case_Guard
);
464 if Present
(Extra_Guard
) then
466 ("contract case must have exactly one case guard",
470 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
472 if Nkind
(Case_Guard
) = N_Others_Choice
then
475 ("only one OTHERS choice allowed in contract cases",
481 elsif Others_Seen
then
483 ("OTHERS must be the last choice in contract cases", N
);
486 -- Preanalyze the case guard and consequence
488 if Nkind
(Case_Guard
) /= N_Others_Choice
then
489 Errors
:= Serious_Errors_Detected
;
490 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
492 -- Emit a clarification message when the case guard contains
493 -- at least one undefined reference, possibly due to contract
496 if Errors
/= Serious_Errors_Detected
497 and then Present
(Freeze_Id
)
498 and then Has_Undefined_Reference
(Case_Guard
)
500 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
504 Errors
:= Serious_Errors_Detected
;
505 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
507 -- Emit a clarification message when the consequence contains
508 -- at least one undefined reference, possibly due to contract
511 if Errors
/= Serious_Errors_Detected
512 and then Present
(Freeze_Id
)
513 and then Has_Undefined_Reference
(Conseq
)
515 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
518 -- The contract case is malformed
521 Error_Msg_N
("wrong syntax in contract case", CCase
);
523 end Analyze_Contract_Case
;
527 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
529 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
530 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
531 -- Save the Ghost-related attributes to restore on exit
534 Restore_Scope
: Boolean := False;
536 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
539 -- Do not analyze the pragma multiple times
541 if Is_Analyzed_Pragma
(N
) then
545 -- Set the Ghost mode in effect from the pragma. Due to the delayed
546 -- analysis of the pragma, the Ghost mode at point of declaration and
547 -- point of analysis may not necessarily be the same. Use the mode in
548 -- effect at the point of declaration.
552 -- Single and multiple contract cases must appear in aggregate form. If
553 -- this is not the case, then either the parser or the analysis of the
554 -- pragma failed to produce an aggregate, e.g. when the contract is
555 -- "null" or a "(null record)".
558 (if Nkind
(CCases
) = N_Aggregate
559 then Null_Record_Present
(CCases
)
560 xor (Present
(Component_Associations
(CCases
))
562 Present
(Expressions
(CCases
)))
563 else Nkind
(CCases
) = N_Null
);
565 -- Only CASE_GUARD => CONSEQUENCE clauses are allowed
567 if Nkind
(CCases
) = N_Aggregate
568 and then Present
(Component_Associations
(CCases
))
569 and then No
(Expressions
(CCases
))
572 -- Check that the expression is a proper aggregate (no parentheses)
574 if Paren_Count
(CCases
) /= 0 then
575 Error_Msg_F
-- CODEFIX
576 ("redundant parentheses", CCases
);
579 -- Ensure that the formal parameters are visible when analyzing all
580 -- clauses. This falls out of the general rule of aspects pertaining
581 -- to subprogram declarations.
583 if not In_Open_Scopes
(Spec_Id
) then
584 Restore_Scope
:= True;
585 Push_Scope
(Spec_Id
);
587 if Is_Generic_Subprogram
(Spec_Id
) then
588 Install_Generic_Formals
(Spec_Id
);
590 Install_Formals
(Spec_Id
);
594 CCase
:= First
(Component_Associations
(CCases
));
595 while Present
(CCase
) loop
596 Analyze_Contract_Case
(CCase
);
600 if Restore_Scope
then
604 -- Currently it is not possible to inline pre/postconditions on a
605 -- subprogram subject to pragma Inline_Always.
607 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
609 -- Otherwise the pragma is illegal
612 Error_Msg_N
("wrong syntax for contract cases", N
);
615 Set_Is_Analyzed_Pragma
(N
);
617 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
618 end Analyze_Contract_Cases_In_Decl_Part
;
620 ----------------------------------
621 -- Analyze_Depends_In_Decl_Part --
622 ----------------------------------
624 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
625 Loc
: constant Source_Ptr
:= Sloc
(N
);
626 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
627 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
629 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
630 -- A list containing the entities of all the inputs processed so far.
631 -- The list is populated with unique entities because the same input
632 -- may appear in multiple input lists.
634 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
635 -- A list containing the entities of all the outputs processed so far.
636 -- The list is populated with unique entities because output items are
637 -- unique in a dependence relation.
639 Constits_Seen
: Elist_Id
:= No_Elist
;
640 -- A list containing the entities of all constituents processed so far.
641 -- It aids in detecting illegal usage of a state and a corresponding
642 -- constituent in pragma [Refinde_]Depends.
644 Global_Seen
: Boolean := False;
645 -- A flag set when pragma Global has been processed
647 Null_Output_Seen
: Boolean := False;
648 -- A flag used to track the legality of a null output
650 Result_Seen
: Boolean := False;
651 -- A flag set when Spec_Id'Result is processed
653 States_Seen
: Elist_Id
:= No_Elist
;
654 -- A list containing the entities of all states processed so far. It
655 -- helps in detecting illegal usage of a state and a corresponding
656 -- constituent in pragma [Refined_]Depends.
658 Subp_Inputs
: Elist_Id
:= No_Elist
;
659 Subp_Outputs
: Elist_Id
:= No_Elist
;
660 -- Two lists containing the full set of inputs and output of the related
661 -- subprograms. Note that these lists contain both nodes and entities.
663 Task_Input_Seen
: Boolean := False;
664 Task_Output_Seen
: Boolean := False;
665 -- Flags used to track the implicit dependence of a task unit on itself
667 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
668 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
669 -- to the name buffer. The individual kinds are as follows:
670 -- E_Abstract_State - "state"
671 -- E_Constant - "constant"
672 -- E_Generic_In_Out_Parameter - "generic parameter"
673 -- E_Generic_In_Parameter - "generic parameter"
674 -- E_In_Parameter - "parameter"
675 -- E_In_Out_Parameter - "parameter"
676 -- E_Loop_Parameter - "loop parameter"
677 -- E_Out_Parameter - "parameter"
678 -- E_Protected_Type - "current instance of protected type"
679 -- E_Task_Type - "current instance of task type"
680 -- E_Variable - "global"
682 procedure Analyze_Dependency_Clause
685 -- Verify the legality of a single dependency clause. Flag Is_Last
686 -- denotes whether Clause is the last clause in the relation.
688 procedure Check_Function_Return
;
689 -- Verify that Funtion'Result appears as one of the outputs
690 -- (SPARK RM 6.1.5(10)).
697 -- Ensure that an item fulfills its designated input and/or output role
698 -- as specified by pragma Global (if any) or the enclosing context. If
699 -- this is not the case, emit an error. Item and Item_Id denote the
700 -- attributes of an item. Flag Is_Input should be set when item comes
701 -- from an input list. Flag Self_Ref should be set when the item is an
702 -- output and the dependency clause has operator "+".
704 procedure Check_Usage
705 (Subp_Items
: Elist_Id
;
706 Used_Items
: Elist_Id
;
708 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
709 -- error if this is not the case.
711 procedure Normalize_Clause
(Clause
: Node_Id
);
712 -- Remove a self-dependency "+" from the input list of a clause
714 -----------------------------
715 -- Add_Item_To_Name_Buffer --
716 -----------------------------
718 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
720 if Ekind
(Item_Id
) = E_Abstract_State
then
721 Add_Str_To_Name_Buffer
("state");
723 elsif Ekind
(Item_Id
) = E_Constant
then
724 Add_Str_To_Name_Buffer
("constant");
726 elsif Is_Formal_Object
(Item_Id
) then
727 Add_Str_To_Name_Buffer
("generic parameter");
729 elsif Is_Formal
(Item_Id
) then
730 Add_Str_To_Name_Buffer
("parameter");
732 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
733 Add_Str_To_Name_Buffer
("loop parameter");
735 elsif Ekind
(Item_Id
) = E_Protected_Type
736 or else Is_Single_Protected_Object
(Item_Id
)
738 Add_Str_To_Name_Buffer
("current instance of protected type");
740 elsif Ekind
(Item_Id
) = E_Task_Type
741 or else Is_Single_Task_Object
(Item_Id
)
743 Add_Str_To_Name_Buffer
("current instance of task type");
745 elsif Ekind
(Item_Id
) = E_Variable
then
746 Add_Str_To_Name_Buffer
("global");
748 -- The routine should not be called with non-SPARK items
753 end Add_Item_To_Name_Buffer
;
755 -------------------------------
756 -- Analyze_Dependency_Clause --
757 -------------------------------
759 procedure Analyze_Dependency_Clause
763 procedure Analyze_Input_List
(Inputs
: Node_Id
);
764 -- Verify the legality of a single input list
766 procedure Analyze_Input_Output
771 Seen
: in out Elist_Id
;
772 Null_Seen
: in out Boolean;
773 Non_Null_Seen
: in out Boolean);
774 -- Verify the legality of a single input or output item. Flag
775 -- Is_Input should be set whenever Item is an input, False when it
776 -- denotes an output. Flag Self_Ref should be set when the item is an
777 -- output and the dependency clause has a "+". Flag Top_Level should
778 -- be set whenever Item appears immediately within an input or output
779 -- list. Seen is a collection of all abstract states, objects and
780 -- formals processed so far. Flag Null_Seen denotes whether a null
781 -- input or output has been encountered. Flag Non_Null_Seen denotes
782 -- whether a non-null input or output has been encountered.
784 ------------------------
785 -- Analyze_Input_List --
786 ------------------------
788 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
789 Inputs_Seen
: Elist_Id
:= No_Elist
;
790 -- A list containing the entities of all inputs that appear in the
791 -- current input list.
793 Non_Null_Input_Seen
: Boolean := False;
794 Null_Input_Seen
: Boolean := False;
795 -- Flags used to check the legality of an input list
800 -- Multiple inputs appear as an aggregate
802 if Nkind
(Inputs
) = N_Aggregate
then
803 if Present
(Component_Associations
(Inputs
)) then
805 ("nested dependency relations not allowed", Inputs
);
807 elsif Present
(Expressions
(Inputs
)) then
808 Input
:= First
(Expressions
(Inputs
));
809 while Present
(Input
) loop
816 Null_Seen
=> Null_Input_Seen
,
817 Non_Null_Seen
=> Non_Null_Input_Seen
);
822 -- Syntax error, always report
825 Error_Msg_N
("malformed input dependency list", Inputs
);
828 -- Process a solitary input
837 Null_Seen
=> Null_Input_Seen
,
838 Non_Null_Seen
=> Non_Null_Input_Seen
);
841 -- Detect an illegal dependency clause of the form
845 if Null_Output_Seen
and then Null_Input_Seen
then
847 ("null dependency clause cannot have a null input list",
850 end Analyze_Input_List
;
852 --------------------------
853 -- Analyze_Input_Output --
854 --------------------------
856 procedure Analyze_Input_Output
861 Seen
: in out Elist_Id
;
862 Null_Seen
: in out Boolean;
863 Non_Null_Seen
: in out Boolean)
865 procedure Current_Task_Instance_Seen
;
866 -- Set the appropriate global flag when the current instance of a
867 -- task unit is encountered.
869 --------------------------------
870 -- Current_Task_Instance_Seen --
871 --------------------------------
873 procedure Current_Task_Instance_Seen
is
876 Task_Input_Seen
:= True;
878 Task_Output_Seen
:= True;
880 end Current_Task_Instance_Seen
;
884 Is_Output
: constant Boolean := not Is_Input
;
888 -- Start of processing for Analyze_Input_Output
891 -- Multiple input or output items appear as an aggregate
893 if Nkind
(Item
) = N_Aggregate
then
894 if not Top_Level
then
895 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
897 elsif Present
(Component_Associations
(Item
)) then
899 ("nested dependency relations not allowed", Item
);
901 -- Recursively analyze the grouped items
903 elsif Present
(Expressions
(Item
)) then
904 Grouped
:= First
(Expressions
(Item
));
905 while Present
(Grouped
) loop
908 Is_Input
=> Is_Input
,
909 Self_Ref
=> Self_Ref
,
912 Null_Seen
=> Null_Seen
,
913 Non_Null_Seen
=> Non_Null_Seen
);
918 -- Syntax error, always report
921 Error_Msg_N
("malformed dependency list", Item
);
924 -- Process attribute 'Result in the context of a dependency clause
926 elsif Is_Attribute_Result
(Item
) then
927 Non_Null_Seen
:= True;
931 -- Attribute 'Result is allowed to appear on the output side of
932 -- a dependency clause (SPARK RM 6.1.5(6)).
935 SPARK_Msg_N
("function result cannot act as input", Item
);
939 ("cannot mix null and non-null dependency items", Item
);
945 -- Detect multiple uses of null in a single dependency list or
946 -- throughout the whole relation. Verify the placement of a null
947 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
949 elsif Nkind
(Item
) = N_Null
then
952 ("multiple null dependency relations not allowed", Item
);
954 elsif Non_Null_Seen
then
956 ("cannot mix null and non-null dependency items", Item
);
964 ("null output list must be the last clause in a "
965 & "dependency relation", Item
);
967 -- Catch a useless dependence of the form:
972 ("useless dependence, null depends on itself", Item
);
980 Non_Null_Seen
:= True;
983 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
987 Resolve_State
(Item
);
989 -- Find the entity of the item. If this is a renaming, climb
990 -- the renaming chain to reach the root object. Renamings of
991 -- non-entire objects do not yield an entity (Empty).
993 Item_Id
:= Entity_Of
(Item
);
995 if Present
(Item_Id
) then
999 if Ekind
(Item_Id
) in E_Constant | E_Loop_Parameter
1002 -- Current instances of concurrent types
1004 Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
1007 -- Formal parameters
1009 Ekind
(Item_Id
) in E_Generic_In_Out_Parameter
1010 | E_Generic_In_Parameter
1012 | E_In_Out_Parameter
1016 -- States, variables
1018 Ekind
(Item_Id
) in E_Abstract_State | E_Variable
1020 -- A [generic] function is not allowed to have Output
1021 -- items in its dependency relations. Note that "null"
1022 -- and attribute 'Result are still valid items.
1024 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1025 and then not Is_Input
1028 ("output item is not applicable to function", Item
);
1031 -- The item denotes a concurrent type. Note that single
1032 -- protected/task types are not considered here because
1033 -- they behave as objects in the context of pragma
1034 -- [Refined_]Depends.
1036 if Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
1038 -- This use is legal as long as the concurrent type is
1039 -- the current instance of an enclosing type.
1041 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
1043 -- The dependence of a task unit on itself is
1044 -- implicit and may or may not be explicitly
1045 -- specified (SPARK RM 6.1.4).
1047 if Ekind
(Item_Id
) = E_Task_Type
then
1048 Current_Task_Instance_Seen
;
1051 -- Otherwise this is not the current instance
1055 ("invalid use of subtype mark in dependency "
1056 & "relation", Item
);
1059 -- The dependency of a task unit on itself is implicit
1060 -- and may or may not be explicitly specified
1061 -- (SPARK RM 6.1.4).
1063 elsif Is_Single_Task_Object
(Item_Id
)
1064 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
1066 Current_Task_Instance_Seen
;
1069 -- Ensure that the item fulfills its role as input and/or
1070 -- output as specified by pragma Global or the enclosing
1073 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1075 -- Detect multiple uses of the same state, variable or
1076 -- formal parameter. If this is not the case, add the
1077 -- item to the list of processed relations.
1079 if Contains
(Seen
, Item_Id
) then
1081 ("duplicate use of item &", Item
, Item_Id
);
1083 Append_New_Elmt
(Item_Id
, Seen
);
1086 -- Detect illegal use of an input related to a null
1087 -- output. Such input items cannot appear in other
1088 -- input lists (SPARK RM 6.1.5(13)).
1091 and then Null_Output_Seen
1092 and then Contains
(All_Inputs_Seen
, Item_Id
)
1095 ("input of a null output list cannot appear in "
1096 & "multiple input lists", Item
);
1099 -- Add an input or a self-referential output to the list
1100 -- of all processed inputs.
1102 if Is_Input
or else Self_Ref
then
1103 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1106 -- State related checks (SPARK RM 6.1.5(3))
1108 if Ekind
(Item_Id
) = E_Abstract_State
then
1110 -- Package and subprogram bodies are instantiated
1111 -- individually in a separate compiler pass. Due to
1112 -- this mode of instantiation, the refinement of a
1113 -- state may no longer be visible when a subprogram
1114 -- body contract is instantiated. Since the generic
1115 -- template is legal, do not perform this check in
1116 -- the instance to circumvent this oddity.
1121 -- An abstract state with visible refinement cannot
1122 -- appear in pragma [Refined_]Depends as its place
1123 -- must be taken by some of its constituents
1124 -- (SPARK RM 6.1.4(7)).
1126 elsif Has_Visible_Refinement
(Item_Id
) then
1128 ("cannot mention state & in dependence relation",
1130 SPARK_Msg_N
("\use its constituents instead", Item
);
1133 -- If the reference to the abstract state appears in
1134 -- an enclosing package body that will eventually
1135 -- refine the state, record the reference for future
1139 Record_Possible_Body_Reference
1140 (State_Id
=> Item_Id
,
1144 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
1145 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
1148 ("overlaying object & cannot appear in Depends",
1151 ("\use the overlaid object & instead",
1152 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
1156 -- When the item renames an entire object, replace the
1157 -- item with a reference to the object.
1159 if Entity
(Item
) /= Item_Id
then
1161 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1165 -- Add the entity of the current item to the list of
1168 if Ekind
(Item_Id
) = E_Abstract_State
then
1169 Append_New_Elmt
(Item_Id
, States_Seen
);
1171 -- The variable may eventually become a constituent of a
1172 -- single protected/task type. Record the reference now
1173 -- and verify its legality when analyzing the contract of
1174 -- the variable (SPARK RM 9.3).
1176 elsif Ekind
(Item_Id
) = E_Variable
then
1177 Record_Possible_Part_Of_Reference
1182 if Ekind
(Item_Id
) in E_Abstract_State
1185 and then Present
(Encapsulating_State
(Item_Id
))
1187 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1190 -- All other input/output items are illegal
1191 -- (SPARK RM 6.1.5(1)).
1195 ("item must denote parameter, variable, state or "
1196 & "current instance of concurrent type", Item
);
1199 -- All other input/output items are illegal
1200 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1204 ("item must denote parameter, variable, state or current "
1205 & "instance of concurrent type", Item
);
1208 end Analyze_Input_Output
;
1216 Non_Null_Output_Seen
: Boolean := False;
1217 -- Flag used to check the legality of an output list
1219 -- Start of processing for Analyze_Dependency_Clause
1222 Inputs
:= Expression
(Clause
);
1225 -- An input list with a self-dependency appears as operator "+" where
1226 -- the actuals inputs are the right operand.
1228 if Nkind
(Inputs
) = N_Op_Plus
then
1229 Inputs
:= Right_Opnd
(Inputs
);
1233 -- Process the output_list of a dependency_clause
1235 Output
:= First
(Choices
(Clause
));
1236 while Present
(Output
) loop
1237 Analyze_Input_Output
1240 Self_Ref
=> Self_Ref
,
1242 Seen
=> All_Outputs_Seen
,
1243 Null_Seen
=> Null_Output_Seen
,
1244 Non_Null_Seen
=> Non_Null_Output_Seen
);
1249 -- Process the input_list of a dependency_clause
1251 Analyze_Input_List
(Inputs
);
1252 end Analyze_Dependency_Clause
;
1254 ---------------------------
1255 -- Check_Function_Return --
1256 ---------------------------
1258 procedure Check_Function_Return
is
1260 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
1261 and then not Result_Seen
1264 ("result of & must appear in exactly one output list",
1267 end Check_Function_Return
;
1273 procedure Check_Role
1275 Item_Id
: Entity_Id
;
1280 (Item_Is_Input
: out Boolean;
1281 Item_Is_Output
: out Boolean);
1282 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1283 -- Item_Is_Output are set depending on the role.
1285 procedure Role_Error
1286 (Item_Is_Input
: Boolean;
1287 Item_Is_Output
: Boolean);
1288 -- Emit an error message concerning the incorrect use of Item in
1289 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1290 -- denote whether the item is an input and/or an output.
1297 (Item_Is_Input
: out Boolean;
1298 Item_Is_Output
: out Boolean)
1300 -- A constant or an IN parameter of a procedure or a protected
1301 -- entry, if it is of an access-to-variable type, should be
1302 -- handled like a variable, as the underlying memory pointed-to
1303 -- can be modified. Use Adjusted_Kind to do this adjustment.
1305 Adjusted_Kind
: Entity_Kind
:= Ekind
(Item_Id
);
1308 if (Ekind
(Item_Id
) in E_Constant | E_Generic_In_Parameter
1310 (Ekind
(Item_Id
) = E_In_Parameter
1311 and then Ekind
(Scope
(Item_Id
))
1312 not in E_Function | E_Generic_Function
))
1313 and then Is_Access_Variable
(Etype
(Item_Id
))
1314 and then Ekind
(Spec_Id
) not in E_Function
1315 | E_Generic_Function
1317 Adjusted_Kind
:= E_Variable
;
1320 case Adjusted_Kind
is
1324 when E_Abstract_State
=>
1326 -- When pragma Global is present it determines the mode of
1327 -- the abstract state.
1330 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1331 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1333 -- Otherwise the state has a default IN OUT mode, because it
1334 -- behaves as a variable.
1337 Item_Is_Input
:= True;
1338 Item_Is_Output
:= True;
1341 -- Constants and IN parameters
1344 | E_Generic_In_Parameter
1348 -- When pragma Global is present it determines the mode
1349 -- of constant objects as inputs (and such objects cannot
1350 -- appear as outputs in the Global contract).
1353 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1355 Item_Is_Input
:= True;
1358 Item_Is_Output
:= False;
1360 -- Variables and IN OUT parameters, as well as constants and
1361 -- IN parameters of access type which are handled like
1364 when E_Generic_In_Out_Parameter
1365 | E_In_Out_Parameter
1368 -- When pragma Global is present it determines the mode of
1373 -- A variable has mode IN when its type is unconstrained
1374 -- or tagged because array bounds, discriminants or tags
1378 Appears_In
(Subp_Inputs
, Item_Id
)
1379 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1381 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1383 -- Otherwise the variable has a default IN OUT mode
1386 Item_Is_Input
:= True;
1387 Item_Is_Output
:= True;
1390 when E_Out_Parameter
=>
1392 -- An OUT parameter of the related subprogram; it cannot
1393 -- appear in Global.
1395 if Scope
(Item_Id
) = Spec_Id
then
1397 -- The parameter has mode IN if its type is unconstrained
1398 -- or tagged because array bounds, discriminants or tags
1402 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1404 Item_Is_Output
:= True;
1406 -- An OUT parameter of an enclosing subprogram; it can
1407 -- appear in Global and behaves as a read-write variable.
1410 -- When pragma Global is present it determines the mode
1415 -- A variable has mode IN when its type is
1416 -- unconstrained or tagged because array
1417 -- bounds, discriminants or tags can be read.
1420 Appears_In
(Subp_Inputs
, Item_Id
)
1421 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1423 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1425 -- Otherwise the variable has a default IN OUT mode
1428 Item_Is_Input
:= True;
1429 Item_Is_Output
:= True;
1435 when E_Protected_Type
=>
1438 -- A variable has mode IN when its type is unconstrained
1439 -- or tagged because array bounds, discriminants or tags
1443 Appears_In
(Subp_Inputs
, Item_Id
)
1444 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1446 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1449 -- A protected type acts as a formal parameter of mode IN
1450 -- when it applies to a protected function.
1452 if Ekind
(Spec_Id
) = E_Function
then
1453 Item_Is_Input
:= True;
1454 Item_Is_Output
:= False;
1456 -- Otherwise the protected type acts as a formal of mode
1460 Item_Is_Input
:= True;
1461 Item_Is_Output
:= True;
1469 -- When pragma Global is present it determines the mode of
1474 Appears_In
(Subp_Inputs
, Item_Id
)
1475 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1477 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1479 -- Otherwise task types act as IN OUT parameters
1482 Item_Is_Input
:= True;
1483 Item_Is_Output
:= True;
1487 raise Program_Error
;
1495 procedure Role_Error
1496 (Item_Is_Input
: Boolean;
1497 Item_Is_Output
: Boolean)
1502 -- When the item is not part of the input and the output set of
1503 -- the related subprogram, then it appears as extra in pragma
1504 -- [Refined_]Depends.
1506 if not Item_Is_Input
and then not Item_Is_Output
then
1507 Add_Item_To_Name_Buffer
(Item_Id
);
1508 Add_Str_To_Name_Buffer
1509 (" & cannot appear in dependence relation");
1511 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1513 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1515 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1516 & "set of subprogram %"), Item
, Item_Id
);
1518 -- The mode of the item and its role in pragma [Refined_]Depends
1519 -- are in conflict. Construct a detailed message explaining the
1520 -- illegality (SPARK RM 6.1.5(5-6)).
1523 if Item_Is_Input
then
1524 Add_Str_To_Name_Buffer
("read-only");
1526 Add_Str_To_Name_Buffer
("write-only");
1529 Add_Char_To_Name_Buffer
(' ');
1530 Add_Item_To_Name_Buffer
(Item_Id
);
1531 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1533 if Item_Is_Input
then
1534 Add_Str_To_Name_Buffer
("output");
1536 Add_Str_To_Name_Buffer
("input");
1539 Add_Str_To_Name_Buffer
(" in dependence relation");
1541 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), Item
, Item_Id
);
1547 Item_Is_Input
: Boolean;
1548 Item_Is_Output
: Boolean;
1550 -- Start of processing for Check_Role
1553 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1558 if not Item_Is_Input
then
1559 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1562 -- Self-referential item
1565 if not Item_Is_Input
or else not Item_Is_Output
then
1566 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1571 elsif not Item_Is_Output
then
1572 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1580 procedure Check_Usage
1581 (Subp_Items
: Elist_Id
;
1582 Used_Items
: Elist_Id
;
1585 procedure Usage_Error
(Item_Id
: Entity_Id
);
1586 -- Emit an error concerning the illegal usage of an item
1592 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1598 -- Unconstrained and tagged items are not part of the explicit
1599 -- input set of the related subprogram, they do not have to be
1600 -- present in a dependence relation and should not be flagged
1601 -- (SPARK RM 6.1.5(5)).
1603 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1606 Add_Item_To_Name_Buffer
(Item_Id
);
1607 Add_Str_To_Name_Buffer
1608 (" & is missing from input dependence list");
1610 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1612 ("\add `null ='> &` dependency to ignore this input",
1616 -- Output case (SPARK RM 6.1.5(10))
1621 Add_Item_To_Name_Buffer
(Item_Id
);
1622 Add_Str_To_Name_Buffer
1623 (" & is missing from output dependence list");
1625 SPARK_Msg_NE
(To_String
(Global_Name_Buffer
), N
, Item_Id
);
1633 Item_Id
: Entity_Id
;
1635 -- Start of processing for Check_Usage
1638 if No
(Subp_Items
) then
1642 -- Each input or output of the subprogram must appear in a dependency
1645 Elmt
:= First_Elmt
(Subp_Items
);
1646 while Present
(Elmt
) loop
1647 Item
:= Node
(Elmt
);
1649 if Nkind
(Item
) = N_Defining_Identifier
then
1652 Item_Id
:= Entity_Of
(Item
);
1655 -- The item does not appear in a dependency
1657 if Present
(Item_Id
)
1658 and then not Contains
(Used_Items
, Item_Id
)
1660 if Is_Formal
(Item_Id
) then
1661 Usage_Error
(Item_Id
);
1663 -- The current instance of a protected type behaves as a formal
1664 -- parameter (SPARK RM 6.1.4).
1666 elsif Ekind
(Item_Id
) = E_Protected_Type
1667 or else Is_Single_Protected_Object
(Item_Id
)
1669 Usage_Error
(Item_Id
);
1671 -- The current instance of a task type behaves as a formal
1672 -- parameter (SPARK RM 6.1.4).
1674 elsif Ekind
(Item_Id
) = E_Task_Type
1675 or else Is_Single_Task_Object
(Item_Id
)
1677 -- The dependence of a task unit on itself is implicit and
1678 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1679 -- Emit an error if only one input/output is present.
1681 if Task_Input_Seen
/= Task_Output_Seen
then
1682 Usage_Error
(Item_Id
);
1685 -- States and global objects are not used properly only when
1686 -- the subprogram is subject to pragma Global.
1689 and then Ekind
(Item_Id
) in E_Abstract_State
1697 Usage_Error
(Item_Id
);
1705 ----------------------
1706 -- Normalize_Clause --
1707 ----------------------
1709 procedure Normalize_Clause
(Clause
: Node_Id
) is
1710 procedure Create_Or_Modify_Clause
1716 Multiple
: Boolean);
1717 -- Create a brand new clause to represent the self-reference or
1718 -- modify the input and/or output lists of an existing clause. Output
1719 -- denotes a self-referencial output. Outputs is the output list of a
1720 -- clause. Inputs is the input list of a clause. After denotes the
1721 -- clause after which the new clause is to be inserted. Flag In_Place
1722 -- should be set when normalizing the last output of an output list.
1723 -- Flag Multiple should be set when Output comes from a list with
1726 -----------------------------
1727 -- Create_Or_Modify_Clause --
1728 -----------------------------
1730 procedure Create_Or_Modify_Clause
1738 procedure Propagate_Output
1741 -- Handle the various cases of output propagation to the input
1742 -- list. Output denotes a self-referencial output item. Inputs
1743 -- is the input list of a clause.
1745 ----------------------
1746 -- Propagate_Output --
1747 ----------------------
1749 procedure Propagate_Output
1753 function In_Input_List
1755 Inputs
: List_Id
) return Boolean;
1756 -- Determine whether a particulat item appears in the input
1757 -- list of a clause.
1763 function In_Input_List
1765 Inputs
: List_Id
) return Boolean
1770 Elmt
:= First
(Inputs
);
1771 while Present
(Elmt
) loop
1772 if Entity_Of
(Elmt
) = Item
then
1784 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1787 -- Start of processing for Propagate_Output
1790 -- The clause is of the form:
1792 -- (Output =>+ null)
1794 -- Remove null input and replace it with a copy of the output:
1796 -- (Output => Output)
1798 if Nkind
(Inputs
) = N_Null
then
1799 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1801 -- The clause is of the form:
1803 -- (Output =>+ (Input1, ..., InputN))
1805 -- Determine whether the output is not already mentioned in the
1806 -- input list and if not, add it to the list of inputs:
1808 -- (Output => (Output, Input1, ..., InputN))
1810 elsif Nkind
(Inputs
) = N_Aggregate
then
1811 Grouped
:= Expressions
(Inputs
);
1813 if not In_Input_List
1817 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1820 -- The clause is of the form:
1822 -- (Output =>+ Input)
1824 -- If the input does not mention the output, group the two
1827 -- (Output => (Output, Input))
1829 elsif Entity_Of
(Inputs
) /= Output_Id
then
1831 Make_Aggregate
(Loc
,
1832 Expressions
=> New_List
(
1833 New_Copy_Tree
(Output
),
1834 New_Copy_Tree
(Inputs
))));
1836 end Propagate_Output
;
1840 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1841 New_Clause
: Node_Id
;
1843 -- Start of processing for Create_Or_Modify_Clause
1846 -- A null output depending on itself does not require any
1849 if Nkind
(Output
) = N_Null
then
1852 -- A function result cannot depend on itself because it cannot
1853 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1855 elsif Is_Attribute_Result
(Output
) then
1856 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1860 -- When performing the transformation in place, simply add the
1861 -- output to the list of inputs (if not already there). This
1862 -- case arises when dealing with the last output of an output
1863 -- list. Perform the normalization in place to avoid generating
1864 -- a malformed tree.
1867 Propagate_Output
(Output
, Inputs
);
1869 -- A list with multiple outputs is slowly trimmed until only
1870 -- one element remains. When this happens, replace aggregate
1871 -- with the element itself.
1875 Rewrite
(Outputs
, Output
);
1881 -- Unchain the output from its output list as it will appear in
1882 -- a new clause. Note that we cannot simply rewrite the output
1883 -- as null because this will violate the semantics of pragma
1888 -- Generate a new clause of the form:
1889 -- (Output => Inputs)
1892 Make_Component_Association
(Loc
,
1893 Choices
=> New_List
(Output
),
1894 Expression
=> New_Copy_Tree
(Inputs
));
1896 -- The new clause contains replicated content that has already
1897 -- been analyzed. There is not need to reanalyze or renormalize
1900 Set_Analyzed
(New_Clause
);
1903 (Output
=> First
(Choices
(New_Clause
)),
1904 Inputs
=> Expression
(New_Clause
));
1906 Insert_After
(After
, New_Clause
);
1908 end Create_Or_Modify_Clause
;
1912 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1914 Last_Output
: Node_Id
;
1915 Next_Output
: Node_Id
;
1918 -- Start of processing for Normalize_Clause
1921 -- A self-dependency appears as operator "+". Remove the "+" from the
1922 -- tree by moving the real inputs to their proper place.
1924 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1925 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1926 Inputs
:= Expression
(Clause
);
1928 -- Multiple outputs appear as an aggregate
1930 if Nkind
(Outputs
) = N_Aggregate
then
1931 Last_Output
:= Last
(Expressions
(Outputs
));
1933 Output
:= First
(Expressions
(Outputs
));
1934 while Present
(Output
) loop
1936 -- Normalization may remove an output from its list,
1937 -- preserve the subsequent output now.
1939 Next_Output
:= Next
(Output
);
1941 Create_Or_Modify_Clause
1946 In_Place
=> Output
= Last_Output
,
1949 Output
:= Next_Output
;
1955 Create_Or_Modify_Clause
1964 end Normalize_Clause
;
1968 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1969 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1973 Last_Clause
: Node_Id
;
1974 Restore_Scope
: Boolean := False;
1976 -- Start of processing for Analyze_Depends_In_Decl_Part
1979 -- Do not analyze the pragma multiple times
1981 if Is_Analyzed_Pragma
(N
) then
1985 -- Empty dependency list
1987 if Nkind
(Deps
) = N_Null
then
1989 -- Gather all states, objects and formal parameters that the
1990 -- subprogram may depend on. These items are obtained from the
1991 -- parameter profile or pragma [Refined_]Global (if available).
1993 Collect_Subprogram_Inputs_Outputs
1994 (Subp_Id
=> Subp_Id
,
1995 Subp_Inputs
=> Subp_Inputs
,
1996 Subp_Outputs
=> Subp_Outputs
,
1997 Global_Seen
=> Global_Seen
);
1999 -- Verify that every input or output of the subprogram appear in a
2002 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
2003 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
2004 Check_Function_Return
;
2006 -- Dependency clauses appear as component associations of an aggregate
2008 elsif Nkind
(Deps
) = N_Aggregate
then
2010 -- Do not attempt to perform analysis of a syntactically illegal
2011 -- clause as this will lead to misleading errors.
2013 if Has_Extra_Parentheses
(Deps
) then
2017 if Present
(Component_Associations
(Deps
)) then
2018 Last_Clause
:= Last
(Component_Associations
(Deps
));
2020 -- Gather all states, objects and formal parameters that the
2021 -- subprogram may depend on. These items are obtained from the
2022 -- parameter profile or pragma [Refined_]Global (if available).
2024 Collect_Subprogram_Inputs_Outputs
2025 (Subp_Id
=> Subp_Id
,
2026 Subp_Inputs
=> Subp_Inputs
,
2027 Subp_Outputs
=> Subp_Outputs
,
2028 Global_Seen
=> Global_Seen
);
2030 -- When pragma [Refined_]Depends appears on a single concurrent
2031 -- type, it is relocated to the anonymous object.
2033 if Is_Single_Concurrent_Object
(Spec_Id
) then
2036 -- Ensure that the formal parameters are visible when analyzing
2037 -- all clauses. This falls out of the general rule of aspects
2038 -- pertaining to subprogram declarations.
2040 elsif not In_Open_Scopes
(Spec_Id
) then
2041 Restore_Scope
:= True;
2042 Push_Scope
(Spec_Id
);
2044 if Ekind
(Spec_Id
) = E_Task_Type
then
2046 -- Task discriminants cannot appear in the [Refined_]Depends
2047 -- contract, but must be present for the analysis so that we
2048 -- can reject them with an informative error message.
2050 if Has_Discriminants
(Spec_Id
) then
2051 Install_Discriminants
(Spec_Id
);
2054 elsif Is_Generic_Subprogram
(Spec_Id
) then
2055 Install_Generic_Formals
(Spec_Id
);
2058 Install_Formals
(Spec_Id
);
2062 Clause
:= First
(Component_Associations
(Deps
));
2063 while Present
(Clause
) loop
2064 Errors
:= Serious_Errors_Detected
;
2066 -- The normalization mechanism may create extra clauses that
2067 -- contain replicated input and output names. There is no need
2068 -- to reanalyze them.
2070 if not Analyzed
(Clause
) then
2071 Set_Analyzed
(Clause
);
2073 Analyze_Dependency_Clause
2075 Is_Last
=> Clause
= Last_Clause
);
2078 -- Do not normalize a clause if errors were detected (count
2079 -- of Serious_Errors has increased) because the inputs and/or
2080 -- outputs may denote illegal items.
2082 if Serious_Errors_Detected
= Errors
then
2083 Normalize_Clause
(Clause
);
2089 if Restore_Scope
then
2093 -- Verify that every input or output of the subprogram appear in a
2096 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
2097 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
2098 Check_Function_Return
;
2100 -- The dependency list is malformed. This is a syntax error, always
2104 Error_Msg_N
("malformed dependency relation", Deps
);
2108 -- The top level dependency relation is malformed. This is a syntax
2109 -- error, always report.
2112 Error_Msg_N
("malformed dependency relation", Deps
);
2116 -- Ensure that a state and a corresponding constituent do not appear
2117 -- together in pragma [Refined_]Depends.
2119 Check_State_And_Constituent_Use
2120 (States
=> States_Seen
,
2121 Constits
=> Constits_Seen
,
2125 Set_Is_Analyzed_Pragma
(N
);
2126 end Analyze_Depends_In_Decl_Part
;
2128 --------------------------------------------
2129 -- Analyze_External_Property_In_Decl_Part --
2130 --------------------------------------------
2132 procedure Analyze_External_Property_In_Decl_Part
2134 Expr_Val
: out Boolean)
2136 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pragma_Name
(N
));
2137 Arg1
: constant Node_Id
:=
2138 First
(Pragma_Argument_Associations
(N
));
2139 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2140 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2144 -- Do not analyze the pragma multiple times, but set the output
2145 -- parameter to the argument specified by the pragma.
2147 if Is_Analyzed_Pragma
(N
) then
2151 Error_Msg_Name_1
:= Pragma_Name
(N
);
2153 -- An external property pragma must apply to an effectively volatile
2154 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2155 -- The check is performed at the end of the declarative region due to a
2156 -- possible out-of-order arrangement of pragmas:
2159 -- pragma Async_Readers (Obj);
2160 -- pragma Volatile (Obj);
2162 if Prag_Id
/= Pragma_No_Caching
2163 and then not Is_Effectively_Volatile
(Obj_Id
)
2165 if Ekind
(Obj_Id
) = E_Variable
2166 and then No_Caching_Enabled
(Obj_Id
)
2169 ("illegal combination of external property % and property "
2170 & """No_Caching"" (SPARK RM 7.1.2(6))", N
);
2173 ("external property % must apply to a volatile type or object",
2177 -- Pragma No_Caching should only apply to volatile variables of
2178 -- a non-effectively volatile type (SPARK RM 7.1.2).
2180 elsif Prag_Id
= Pragma_No_Caching
then
2181 if Is_Effectively_Volatile
(Etype
(Obj_Id
)) then
2182 SPARK_Msg_N
("property % must not apply to an object of "
2183 & "an effectively volatile type", N
);
2184 elsif not Is_Volatile
(Obj_Id
) then
2185 SPARK_Msg_N
("property % must apply to a volatile object", N
);
2189 Set_Is_Analyzed_Pragma
(N
);
2193 -- Ensure that the Boolean expression (if present) is static. A missing
2194 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2198 if Present
(Arg1
) then
2199 Expr
:= Get_Pragma_Arg
(Arg1
);
2201 if Is_OK_Static_Expression
(Expr
) then
2202 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2206 end Analyze_External_Property_In_Decl_Part
;
2208 ---------------------------------
2209 -- Analyze_Global_In_Decl_Part --
2210 ---------------------------------
2212 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2213 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2214 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2215 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2217 Constits_Seen
: Elist_Id
:= No_Elist
;
2218 -- A list containing the entities of all constituents processed so far.
2219 -- It aids in detecting illegal usage of a state and a corresponding
2220 -- constituent in pragma [Refinde_]Global.
2222 Seen
: Elist_Id
:= No_Elist
;
2223 -- A list containing the entities of all the items processed so far. It
2224 -- plays a role in detecting distinct entities.
2226 States_Seen
: Elist_Id
:= No_Elist
;
2227 -- A list containing the entities of all states processed so far. It
2228 -- helps in detecting illegal usage of a state and a corresponding
2229 -- constituent in pragma [Refined_]Global.
2231 In_Out_Seen
: Boolean := False;
2232 Input_Seen
: Boolean := False;
2233 Output_Seen
: Boolean := False;
2234 Proof_Seen
: Boolean := False;
2235 -- Flags used to verify the consistency of modes
2237 procedure Analyze_Global_List
2239 Global_Mode
: Name_Id
:= Name_Input
);
2240 -- Verify the legality of a single global list declaration. Global_Mode
2241 -- denotes the current mode in effect.
2243 -------------------------
2244 -- Analyze_Global_List --
2245 -------------------------
2247 procedure Analyze_Global_List
2249 Global_Mode
: Name_Id
:= Name_Input
)
2251 procedure Analyze_Global_Item
2253 Global_Mode
: Name_Id
);
2254 -- Verify the legality of a single global item declaration denoted by
2255 -- Item. Global_Mode denotes the current mode in effect.
2257 procedure Check_Duplicate_Mode
2259 Status
: in out Boolean);
2260 -- Flag Status denotes whether a particular mode has been seen while
2261 -- processing a global list. This routine verifies that Mode is not a
2262 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2264 procedure Check_Mode_Restriction_In_Enclosing_Context
2266 Item_Id
: Entity_Id
);
2267 -- Verify that an item of mode In_Out or Output does not appear as
2268 -- an input in the Global aspect of an enclosing subprogram or task
2269 -- unit. If this is the case, emit an error. Item and Item_Id are
2270 -- respectively the item and its entity.
2272 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2273 -- Mode denotes either In_Out or Output. Depending on the kind of the
2274 -- related subprogram, emit an error if those two modes apply to a
2275 -- function (SPARK RM 6.1.4(10)).
2277 -------------------------
2278 -- Analyze_Global_Item --
2279 -------------------------
2281 procedure Analyze_Global_Item
2283 Global_Mode
: Name_Id
)
2285 Item_Id
: Entity_Id
;
2288 -- Detect one of the following cases
2290 -- with Global => (null, Name)
2291 -- with Global => (Name_1, null, Name_2)
2292 -- with Global => (Name, null)
2294 if Nkind
(Item
) = N_Null
then
2295 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2300 Resolve_State
(Item
);
2302 -- Find the entity of the item. If this is a renaming, climb the
2303 -- renaming chain to reach the root object. Renamings of non-
2304 -- entire objects do not yield an entity (Empty).
2306 Item_Id
:= Entity_Of
(Item
);
2308 if Present
(Item_Id
) then
2310 -- A global item may denote a formal parameter of an enclosing
2311 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2312 -- provide a better error diagnostic.
2314 if Is_Formal
(Item_Id
) then
2315 if Scope
(Item_Id
) = Spec_Id
then
2317 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2318 & "parameter of subprogram &"), Item
, Spec_Id
);
2322 -- A global item may denote a concurrent type as long as it is
2323 -- the current instance of an enclosing protected or task type
2324 -- (SPARK RM 6.1.4).
2326 elsif Ekind
(Item_Id
) in E_Protected_Type | E_Task_Type
then
2327 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2329 -- Pragma [Refined_]Global associated with a protected
2330 -- subprogram cannot mention the current instance of a
2331 -- protected type because the instance behaves as a
2332 -- formal parameter.
2334 if Ekind
(Item_Id
) = E_Protected_Type
then
2335 if Scope
(Spec_Id
) = Item_Id
then
2336 Error_Msg_Name_1
:= Chars
(Item_Id
);
2338 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2339 & "cannot reference current instance of "
2340 & "protected type %"), Item
, Spec_Id
);
2344 -- Pragma [Refined_]Global associated with a task type
2345 -- cannot mention the current instance of a task type
2346 -- because the instance behaves as a formal parameter.
2348 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2349 if Spec_Id
= Item_Id
then
2350 Error_Msg_Name_1
:= Chars
(Item_Id
);
2352 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2353 & "cannot reference current instance of task "
2354 & "type %"), Item
, Spec_Id
);
2359 -- Otherwise the global item denotes a subtype mark that is
2360 -- not a current instance.
2364 ("invalid use of subtype mark in global list", Item
);
2368 -- A global item may denote the anonymous object created for a
2369 -- single protected/task type as long as the current instance
2370 -- is the same single type (SPARK RM 6.1.4).
2372 elsif Is_Single_Concurrent_Object
(Item_Id
)
2373 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2375 -- Pragma [Refined_]Global associated with a protected
2376 -- subprogram cannot mention the current instance of a
2377 -- protected type because the instance behaves as a formal
2380 if Is_Single_Protected_Object
(Item_Id
) then
2381 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2382 Error_Msg_Name_1
:= Chars
(Item_Id
);
2384 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2385 & "cannot reference current instance of protected "
2386 & "type %"), Item
, Spec_Id
);
2390 -- Pragma [Refined_]Global associated with a task type
2391 -- cannot mention the current instance of a task type
2392 -- because the instance behaves as a formal parameter.
2394 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2395 if Spec_Id
= Item_Id
then
2396 Error_Msg_Name_1
:= Chars
(Item_Id
);
2398 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2399 & "cannot reference current instance of task "
2400 & "type %"), Item
, Spec_Id
);
2405 -- A formal object may act as a global item inside a generic
2407 elsif Is_Formal_Object
(Item_Id
) then
2410 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
2411 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
2414 ("overlaying object & cannot appear in Global",
2417 ("\use the overlaid object & instead",
2418 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
2421 -- The only legal references are those to abstract states,
2422 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2424 elsif Ekind
(Item_Id
) not in E_Abstract_State
2430 ("global item must denote object, state or current "
2431 & "instance of concurrent type", Item
);
2433 if Is_Named_Number
(Item_Id
) then
2435 ("\named number & is not an object", Item
, Item_Id
);
2441 -- State related checks
2443 if Ekind
(Item_Id
) = E_Abstract_State
then
2445 -- Package and subprogram bodies are instantiated
2446 -- individually in a separate compiler pass. Due to this
2447 -- mode of instantiation, the refinement of a state may
2448 -- no longer be visible when a subprogram body contract
2449 -- is instantiated. Since the generic template is legal,
2450 -- do not perform this check in the instance to circumvent
2456 -- An abstract state with visible refinement cannot appear
2457 -- in pragma [Refined_]Global as its place must be taken by
2458 -- some of its constituents (SPARK RM 6.1.4(7)).
2460 elsif Has_Visible_Refinement
(Item_Id
) then
2462 ("cannot mention state & in global refinement",
2464 SPARK_Msg_N
("\use its constituents instead", Item
);
2467 -- An external state which has Async_Writers or
2468 -- Effective_Reads enabled cannot appear as a global item
2469 -- of a nonvolatile function (SPARK RM 7.1.3(8)).
2471 elsif Is_External_State
(Item_Id
)
2472 and then (Async_Writers_Enabled
(Item_Id
)
2473 or else Effective_Reads_Enabled
(Item_Id
))
2474 and then Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2475 and then not Is_Volatile_Function
(Spec_Id
)
2478 ("external state & cannot act as global item of "
2479 & "nonvolatile function", Item
, Item_Id
);
2482 -- If the reference to the abstract state appears in an
2483 -- enclosing package body that will eventually refine the
2484 -- state, record the reference for future checks.
2487 Record_Possible_Body_Reference
2488 (State_Id
=> Item_Id
,
2492 -- Constant related checks
2494 elsif Ekind
(Item_Id
) = E_Constant
then
2496 -- Constant is a read-only item, therefore it cannot act as
2499 if Global_Mode
in Name_In_Out | Name_Output
then
2501 -- Constant of an access-to-variable type is a read-write
2502 -- item in procedures, generic procedures, protected
2503 -- entries and tasks.
2505 if Is_Access_Variable
(Etype
(Item_Id
))
2506 and then (Ekind
(Spec_Id
) in E_Entry
2509 | E_Generic_Procedure
2511 or else Is_Single_Task_Object
(Spec_Id
))
2516 ("constant & cannot act as output", Item
, Item_Id
);
2521 -- Loop parameter related checks
2523 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2525 -- A loop parameter is a read-only item, therefore it cannot
2526 -- act as an output.
2528 if Global_Mode
in Name_In_Out | Name_Output
then
2530 ("loop parameter & cannot act as output",
2535 -- Variable related checks. These are only relevant when
2536 -- SPARK_Mode is on as they are not standard Ada legality
2539 elsif SPARK_Mode
= On
2540 and then Ekind
(Item_Id
) = E_Variable
2541 and then Is_Effectively_Volatile_For_Reading
(Item_Id
)
2543 -- The current instance of a protected unit is not an
2544 -- effectively volatile object, unless the protected unit
2545 -- is already volatile for another reason (SPARK RM 7.1.2).
2547 if Is_Single_Protected_Object
(Item_Id
)
2548 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2549 and then not Is_Effectively_Volatile_For_Reading
2550 (Item_Id
, Ignore_Protected
=> True)
2554 -- An effectively volatile object for reading cannot appear
2555 -- as a global item of a nonvolatile function (SPARK RM
2558 elsif Ekind
(Spec_Id
) in E_Function | E_Generic_Function
2559 and then not Is_Volatile_Function
(Spec_Id
)
2562 ("volatile object & cannot act as global item of a "
2563 & "function", Item
, Item_Id
);
2566 -- An effectively volatile object with external property
2567 -- Effective_Reads set to True must have mode Output or
2568 -- In_Out (SPARK RM 7.1.3(10)).
2570 elsif Effective_Reads_Enabled
(Item_Id
)
2571 and then Global_Mode
= Name_Input
2574 ("volatile object & with property Effective_Reads must "
2575 & "have mode In_Out or Output", Item
, Item_Id
);
2580 -- When the item renames an entire object, replace the item
2581 -- with a reference to the object.
2583 if Entity
(Item
) /= Item_Id
then
2584 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2588 -- Some form of illegal construct masquerading as a name
2589 -- (SPARK RM 6.1.4(4)).
2593 ("global item must denote object, state or current instance "
2594 & "of concurrent type", Item
);
2598 -- Verify that an output does not appear as an input in an
2599 -- enclosing subprogram.
2601 if Global_Mode
in Name_In_Out | Name_Output
then
2602 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2605 -- The same entity might be referenced through various way.
2606 -- Check the entity of the item rather than the item itself
2607 -- (SPARK RM 6.1.4(10)).
2609 if Contains
(Seen
, Item_Id
) then
2610 SPARK_Msg_N
("duplicate global item", Item
);
2612 -- Add the entity of the current item to the list of processed
2616 Append_New_Elmt
(Item_Id
, Seen
);
2618 if Ekind
(Item_Id
) = E_Abstract_State
then
2619 Append_New_Elmt
(Item_Id
, States_Seen
);
2621 -- The variable may eventually become a constituent of a single
2622 -- protected/task type. Record the reference now and verify its
2623 -- legality when analyzing the contract of the variable
2626 elsif Ekind
(Item_Id
) = E_Variable
then
2627 Record_Possible_Part_Of_Reference
2632 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
2633 and then Present
(Encapsulating_State
(Item_Id
))
2635 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2638 end Analyze_Global_Item
;
2640 --------------------------
2641 -- Check_Duplicate_Mode --
2642 --------------------------
2644 procedure Check_Duplicate_Mode
2646 Status
: in out Boolean)
2650 SPARK_Msg_N
("duplicate global mode", Mode
);
2654 end Check_Duplicate_Mode
;
2656 -------------------------------------------------
2657 -- Check_Mode_Restriction_In_Enclosing_Context --
2658 -------------------------------------------------
2660 procedure Check_Mode_Restriction_In_Enclosing_Context
2662 Item_Id
: Entity_Id
)
2664 Context
: Entity_Id
;
2666 Inputs
: Elist_Id
:= No_Elist
;
2667 Outputs
: Elist_Id
:= No_Elist
;
2670 -- Traverse the scope stack looking for enclosing subprograms or
2671 -- tasks subject to pragma [Refined_]Global.
2673 Context
:= Scope
(Subp_Id
);
2674 while Present
(Context
) and then Context
/= Standard_Standard
loop
2676 -- For a single task type, retrieve the corresponding object to
2677 -- which pragma [Refined_]Global is attached.
2679 if Ekind
(Context
) = E_Task_Type
2680 and then Is_Single_Concurrent_Type
(Context
)
2682 Context
:= Anonymous_Object
(Context
);
2685 if Is_Subprogram_Or_Entry
(Context
)
2686 or else Ekind
(Context
) = E_Task_Type
2687 or else Is_Single_Task_Object
(Context
)
2689 Collect_Subprogram_Inputs_Outputs
2690 (Subp_Id
=> Context
,
2691 Subp_Inputs
=> Inputs
,
2692 Subp_Outputs
=> Outputs
,
2693 Global_Seen
=> Dummy
);
2695 -- The item is classified as In_Out or Output but appears as
2696 -- an Input or a formal parameter of mode IN in an enclosing
2697 -- subprogram or task unit (SPARK RM 6.1.4(13)).
2699 if Appears_In
(Inputs
, Item_Id
)
2700 and then not Appears_In
(Outputs
, Item_Id
)
2703 ("global item & cannot have mode In_Out or Output",
2706 if Is_Subprogram_Or_Entry
(Context
) then
2708 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2709 & "of subprogram &"), Item
, Context
);
2712 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2713 & "of task &"), Item
, Context
);
2716 -- Stop the traversal once an error has been detected
2722 Context
:= Scope
(Context
);
2724 end Check_Mode_Restriction_In_Enclosing_Context
;
2726 ----------------------------------------
2727 -- Check_Mode_Restriction_In_Function --
2728 ----------------------------------------
2730 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2732 if Ekind
(Spec_Id
) in E_Function | E_Generic_Function
then
2734 ("global mode & is not applicable to functions", Mode
);
2736 end Check_Mode_Restriction_In_Function
;
2744 -- Start of processing for Analyze_Global_List
2747 if Nkind
(List
) = N_Null
then
2748 Set_Analyzed
(List
);
2750 -- Single global item declaration
2752 elsif Nkind
(List
) in N_Expanded_Name
2754 | N_Selected_Component
2756 Analyze_Global_Item
(List
, Global_Mode
);
2758 -- Simple global list or moded global list declaration
2760 elsif Nkind
(List
) = N_Aggregate
then
2761 Set_Analyzed
(List
);
2763 -- The declaration of a simple global list appear as a collection
2766 if Present
(Expressions
(List
)) then
2767 if Present
(Component_Associations
(List
)) then
2769 ("cannot mix moded and non-moded global lists", List
);
2772 Item
:= First
(Expressions
(List
));
2773 while Present
(Item
) loop
2774 Analyze_Global_Item
(Item
, Global_Mode
);
2778 -- The declaration of a moded global list appears as a collection
2779 -- of component associations where individual choices denote
2782 elsif Present
(Component_Associations
(List
)) then
2783 if Present
(Expressions
(List
)) then
2785 ("cannot mix moded and non-moded global lists", List
);
2788 Assoc
:= First
(Component_Associations
(List
));
2789 while Present
(Assoc
) loop
2790 Mode
:= First
(Choices
(Assoc
));
2792 if Nkind
(Mode
) = N_Identifier
then
2793 if Chars
(Mode
) = Name_In_Out
then
2794 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2795 Check_Mode_Restriction_In_Function
(Mode
);
2797 elsif Chars
(Mode
) = Name_Input
then
2798 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2800 elsif Chars
(Mode
) = Name_Output
then
2801 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2802 Check_Mode_Restriction_In_Function
(Mode
);
2804 elsif Chars
(Mode
) = Name_Proof_In
then
2805 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2808 SPARK_Msg_N
("invalid mode selector", Mode
);
2812 SPARK_Msg_N
("invalid mode selector", Mode
);
2815 -- Items in a moded list appear as a collection of
2816 -- expressions. Reuse the existing machinery to analyze
2820 (List
=> Expression
(Assoc
),
2821 Global_Mode
=> Chars
(Mode
));
2829 raise Program_Error
;
2832 -- Any other attempt to declare a global item is illegal. This is a
2833 -- syntax error, always report.
2836 Error_Msg_N
("malformed global list", List
);
2838 end Analyze_Global_List
;
2842 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2844 Restore_Scope
: Boolean := False;
2846 -- Start of processing for Analyze_Global_In_Decl_Part
2849 -- Do not analyze the pragma multiple times
2851 if Is_Analyzed_Pragma
(N
) then
2855 -- There is nothing to be done for a null global list
2857 if Nkind
(Items
) = N_Null
then
2858 Set_Analyzed
(Items
);
2860 -- Analyze the various forms of global lists and items. Note that some
2861 -- of these may be malformed in which case the analysis emits error
2865 -- When pragma [Refined_]Global appears on a single concurrent type,
2866 -- it is relocated to the anonymous object.
2868 if Is_Single_Concurrent_Object
(Spec_Id
) then
2871 -- Ensure that the formal parameters are visible when processing an
2872 -- item. This falls out of the general rule of aspects pertaining to
2873 -- subprogram declarations.
2875 elsif not In_Open_Scopes
(Spec_Id
) then
2876 Restore_Scope
:= True;
2877 Push_Scope
(Spec_Id
);
2879 if Ekind
(Spec_Id
) = E_Task_Type
then
2881 -- Task discriminants cannot appear in the [Refined_]Global
2882 -- contract, but must be present for the analysis so that we
2883 -- can reject them with an informative error message.
2885 if Has_Discriminants
(Spec_Id
) then
2886 Install_Discriminants
(Spec_Id
);
2889 elsif Is_Generic_Subprogram
(Spec_Id
) then
2890 Install_Generic_Formals
(Spec_Id
);
2893 Install_Formals
(Spec_Id
);
2897 Analyze_Global_List
(Items
);
2899 if Restore_Scope
then
2904 -- Ensure that a state and a corresponding constituent do not appear
2905 -- together in pragma [Refined_]Global.
2907 Check_State_And_Constituent_Use
2908 (States
=> States_Seen
,
2909 Constits
=> Constits_Seen
,
2912 Set_Is_Analyzed_Pragma
(N
);
2913 end Analyze_Global_In_Decl_Part
;
2915 --------------------------------------------
2916 -- Analyze_Initial_Condition_In_Decl_Part --
2917 --------------------------------------------
2919 -- WARNING: This routine manages Ghost regions. Return statements must be
2920 -- replaced by gotos which jump to the end of the routine and restore the
2923 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2924 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2925 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2926 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2928 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2929 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2930 -- Save the Ghost-related attributes to restore on exit
2933 -- Do not analyze the pragma multiple times
2935 if Is_Analyzed_Pragma
(N
) then
2939 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2940 -- analysis of the pragma, the Ghost mode at point of declaration and
2941 -- point of analysis may not necessarily be the same. Use the mode in
2942 -- effect at the point of declaration.
2946 -- The expression is preanalyzed because it has not been moved to its
2947 -- final place yet. A direct analysis may generate side effects and this
2948 -- is not desired at this point.
2950 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2951 Set_Is_Analyzed_Pragma
(N
);
2953 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2954 end Analyze_Initial_Condition_In_Decl_Part
;
2956 --------------------------------------
2957 -- Analyze_Initializes_In_Decl_Part --
2958 --------------------------------------
2960 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2961 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2962 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2964 Constits_Seen
: Elist_Id
:= No_Elist
;
2965 -- A list containing the entities of all constituents processed so far.
2966 -- It aids in detecting illegal usage of a state and a corresponding
2967 -- constituent in pragma Initializes.
2969 Items_Seen
: Elist_Id
:= No_Elist
;
2970 -- A list of all initialization items processed so far. This list is
2971 -- used to detect duplicate items.
2973 States_And_Objs
: Elist_Id
:= No_Elist
;
2974 -- A list of all abstract states and objects declared in the visible
2975 -- declarations of the related package. This list is used to detect the
2976 -- legality of initialization items.
2978 States_Seen
: Elist_Id
:= No_Elist
;
2979 -- A list containing the entities of all states processed so far. It
2980 -- helps in detecting illegal usage of a state and a corresponding
2981 -- constituent in pragma Initializes.
2983 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2984 -- Verify the legality of a single initialization item
2986 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2987 -- Verify the legality of a single initialization item followed by a
2988 -- list of input items.
2990 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
);
2991 -- Inspect the visible declarations of the related package and gather
2992 -- the entities of all abstract states and objects in States_And_Objs.
2994 ---------------------------------
2995 -- Analyze_Initialization_Item --
2996 ---------------------------------
2998 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2999 Item_Id
: Entity_Id
;
3003 Resolve_State
(Item
);
3005 if Is_Entity_Name
(Item
) then
3006 Item_Id
:= Entity_Of
(Item
);
3008 if Present
(Item_Id
)
3009 and then Ekind
(Item_Id
) in
3010 E_Abstract_State | E_Constant | E_Variable
3012 -- When the initialization item is undefined, it appears as
3013 -- Any_Id. Do not continue with the analysis of the item.
3015 if Item_Id
= Any_Id
then
3018 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
3019 and then Present
(Ultimate_Overlaid_Entity
(Item_Id
))
3022 ("overlaying object & cannot appear in Initializes",
3025 ("\use the overlaid object & instead",
3026 Item
, Ultimate_Overlaid_Entity
(Item_Id
));
3028 -- The state or variable must be declared in the visible
3029 -- declarations of the package (SPARK RM 7.1.5(7)).
3031 elsif not Contains
(States_And_Objs
, Item_Id
) then
3032 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3034 ("initialization item & must appear in the visible "
3035 & "declarations of package %", Item
, Item_Id
);
3037 -- Detect a duplicate use of the same initialization item
3038 -- (SPARK RM 7.1.5(5)).
3040 elsif Contains
(Items_Seen
, Item_Id
) then
3041 SPARK_Msg_N
("duplicate initialization item", Item
);
3043 -- The item is legal, add it to the list of processed states
3047 Append_New_Elmt
(Item_Id
, Items_Seen
);
3049 if Ekind
(Item_Id
) = E_Abstract_State
then
3050 Append_New_Elmt
(Item_Id
, States_Seen
);
3053 if Present
(Encapsulating_State
(Item_Id
)) then
3054 Append_New_Elmt
(Item_Id
, Constits_Seen
);
3058 -- The item references something that is not a state or object
3059 -- (SPARK RM 7.1.5(3)).
3063 ("initialization item must denote object or state", Item
);
3066 -- Some form of illegal construct masquerading as a name
3067 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3071 ("initialization item must denote object or state", Item
);
3073 end Analyze_Initialization_Item
;
3075 ---------------------------------------------
3076 -- Analyze_Initialization_Item_With_Inputs --
3077 ---------------------------------------------
3079 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
3080 Inputs_Seen
: Elist_Id
:= No_Elist
;
3081 -- A list of all inputs processed so far. This list is used to detect
3082 -- duplicate uses of an input.
3084 Non_Null_Seen
: Boolean := False;
3085 Null_Seen
: Boolean := False;
3086 -- Flags used to check the legality of an input list
3088 procedure Analyze_Input_Item
(Input
: Node_Id
);
3089 -- Verify the legality of a single input item
3091 ------------------------
3092 -- Analyze_Input_Item --
3093 ------------------------
3095 procedure Analyze_Input_Item
(Input
: Node_Id
) is
3096 Input_Id
: Entity_Id
;
3101 if Nkind
(Input
) = N_Null
then
3104 ("multiple null initializations not allowed", Item
);
3106 elsif Non_Null_Seen
then
3108 ("cannot mix null and non-null initialization item", Item
);
3116 Non_Null_Seen
:= True;
3120 ("cannot mix null and non-null initialization item", Item
);
3124 Resolve_State
(Input
);
3126 if Is_Entity_Name
(Input
) then
3127 Input_Id
:= Entity_Of
(Input
);
3129 if Present
(Input_Id
)
3130 and then Ekind
(Input_Id
) in E_Abstract_State
3132 | E_Generic_In_Out_Parameter
3133 | E_Generic_In_Parameter
3135 | E_In_Out_Parameter
3141 -- The input cannot denote states or objects declared
3142 -- within the related package (SPARK RM 7.1.5(4)).
3144 if Within_Scope
(Input_Id
, Current_Scope
) then
3146 -- Do not consider generic formal parameters or their
3147 -- respective mappings to generic formals. Even though
3148 -- the formals appear within the scope of the package,
3149 -- it is allowed for an initialization item to depend
3150 -- on an input item.
3152 if Is_Formal_Object
(Input_Id
) then
3155 elsif Ekind
(Input_Id
) in E_Constant | E_Variable
3156 and then Present
(Corresponding_Generic_Association
3157 (Declaration_Node
(Input_Id
)))
3162 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3164 ("input item & cannot denote a visible object or "
3165 & "state of package %", Input
, Input_Id
);
3170 if Ekind
(Input_Id
) in E_Constant | E_Variable
3171 and then Present
(Ultimate_Overlaid_Entity
(Input_Id
))
3174 ("overlaying object & cannot appear in Initializes",
3177 ("\use the overlaid object & instead",
3178 Input
, Ultimate_Overlaid_Entity
(Input_Id
));
3182 -- Detect a duplicate use of the same input item
3183 -- (SPARK RM 7.1.5(5)).
3185 if Contains
(Inputs_Seen
, Input_Id
) then
3186 SPARK_Msg_N
("duplicate input item", Input
);
3190 -- At this point it is known that the input is legal. Add
3191 -- it to the list of processed inputs.
3193 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
3195 if Ekind
(Input_Id
) = E_Abstract_State
then
3196 Append_New_Elmt
(Input_Id
, States_Seen
);
3199 if Ekind
(Input_Id
) in E_Abstract_State
3202 and then Present
(Encapsulating_State
(Input_Id
))
3204 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3207 -- The input references something that is not a state or an
3208 -- object (SPARK RM 7.1.5(3)).
3212 ("input item must denote object or state", Input
);
3215 -- Some form of illegal construct masquerading as a name
3216 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3220 ("input item must denote object or state", Input
);
3223 end Analyze_Input_Item
;
3227 Inputs
: constant Node_Id
:= Expression
(Item
);
3231 Name_Seen
: Boolean := False;
3232 -- A flag used to detect multiple item names
3234 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3237 -- Inspect the name of an item with inputs
3239 Elmt
:= First
(Choices
(Item
));
3240 while Present
(Elmt
) loop
3242 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3245 Analyze_Initialization_Item
(Elmt
);
3251 -- Multiple input items appear as an aggregate
3253 if Nkind
(Inputs
) = N_Aggregate
then
3254 if Present
(Expressions
(Inputs
)) then
3255 Input
:= First
(Expressions
(Inputs
));
3256 while Present
(Input
) loop
3257 Analyze_Input_Item
(Input
);
3262 if Present
(Component_Associations
(Inputs
)) then
3264 ("inputs must appear in named association form", Inputs
);
3267 -- Single input item
3270 Analyze_Input_Item
(Inputs
);
3272 end Analyze_Initialization_Item_With_Inputs
;
3274 --------------------------------
3275 -- Collect_States_And_Objects --
3276 --------------------------------
3278 procedure Collect_States_And_Objects
(Pack_Decl
: Node_Id
) is
3279 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3280 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
3282 State_Elmt
: Elmt_Id
;
3285 -- Collect the abstract states defined in the package (if any)
3287 if Has_Non_Null_Abstract_State
(Pack_Id
) then
3288 State_Elmt
:= First_Elmt
(Abstract_States
(Pack_Id
));
3289 while Present
(State_Elmt
) loop
3290 Append_New_Elmt
(Node
(State_Elmt
), States_And_Objs
);
3291 Next_Elmt
(State_Elmt
);
3295 -- Collect all objects that appear in the visible declarations of the
3298 if Present
(Visible_Declarations
(Pack_Spec
)) then
3299 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3300 while Present
(Decl
) loop
3301 if Comes_From_Source
(Decl
)
3302 and then Nkind
(Decl
) in N_Object_Declaration
3303 | N_Object_Renaming_Declaration
3305 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3307 elsif Nkind
(Decl
) = N_Package_Declaration
then
3308 Collect_States_And_Objects
(Decl
);
3310 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3312 (Anonymous_Object
(Defining_Entity
(Decl
)),
3319 end Collect_States_And_Objects
;
3323 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3326 -- Start of processing for Analyze_Initializes_In_Decl_Part
3329 -- Do not analyze the pragma multiple times
3331 if Is_Analyzed_Pragma
(N
) then
3335 -- Nothing to do when the initialization list is empty
3337 if Nkind
(Inits
) = N_Null
then
3341 -- Single and multiple initialization clauses appear as an aggregate. If
3342 -- this is not the case, then either the parser or the analysis of the
3343 -- pragma failed to produce an aggregate.
3345 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3347 -- Initialize the various lists used during analysis
3349 Collect_States_And_Objects
(Pack_Decl
);
3351 if Present
(Expressions
(Inits
)) then
3352 Init
:= First
(Expressions
(Inits
));
3353 while Present
(Init
) loop
3354 Analyze_Initialization_Item
(Init
);
3359 if Present
(Component_Associations
(Inits
)) then
3360 Init
:= First
(Component_Associations
(Inits
));
3361 while Present
(Init
) loop
3362 Analyze_Initialization_Item_With_Inputs
(Init
);
3367 -- Ensure that a state and a corresponding constituent do not appear
3368 -- together in pragma Initializes.
3370 Check_State_And_Constituent_Use
3371 (States
=> States_Seen
,
3372 Constits
=> Constits_Seen
,
3375 Set_Is_Analyzed_Pragma
(N
);
3376 end Analyze_Initializes_In_Decl_Part
;
3378 ---------------------
3379 -- Analyze_Part_Of --
3380 ---------------------
3382 procedure Analyze_Part_Of
3384 Item_Id
: Entity_Id
;
3386 Encap_Id
: out Entity_Id
;
3387 Legal
: out Boolean)
3389 procedure Check_Part_Of_Abstract_State
;
3390 pragma Inline
(Check_Part_Of_Abstract_State
);
3391 -- Verify the legality of indicator Part_Of when the encapsulator is an
3394 procedure Check_Part_Of_Concurrent_Type
;
3395 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3396 -- Verify the legality of indicator Part_Of when the encapsulator is a
3397 -- single concurrent type.
3399 ----------------------------------
3400 -- Check_Part_Of_Abstract_State --
3401 ----------------------------------
3403 procedure Check_Part_Of_Abstract_State
is
3404 Pack_Id
: Entity_Id
;
3405 Placement
: State_Space_Kind
;
3406 Parent_Unit
: Entity_Id
;
3409 -- Determine where the object, package instantiation or state lives
3410 -- with respect to the enclosing packages or package bodies.
3412 Find_Placement_In_State_Space
3413 (Item_Id
=> Item_Id
,
3414 Placement
=> Placement
,
3415 Pack_Id
=> Pack_Id
);
3417 -- The item appears in a non-package construct with a declarative
3418 -- part (subprogram, block, etc). As such, the item is not allowed
3419 -- to be a part of an encapsulating state because the item is not
3422 if Placement
= Not_In_Package
then
3424 ("indicator Part_Of cannot appear in this context "
3425 & "(SPARK RM 7.2.6(5))", Indic
);
3427 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3429 ("\& is not part of the hidden state of package %",
3433 -- The item appears in the visible state space of some package. In
3434 -- general this scenario does not warrant Part_Of except when the
3435 -- package is a nongeneric private child unit and the encapsulating
3436 -- state is declared in a parent unit or a public descendant of that
3439 elsif Placement
= Visible_State_Space
then
3440 if Is_Child_Unit
(Pack_Id
)
3441 and then not Is_Generic_Unit
(Pack_Id
)
3442 and then Is_Private_Descendant
(Pack_Id
)
3444 -- A variable or state abstraction which is part of the visible
3445 -- state of a nongeneric private child unit or its public
3446 -- descendants must have its Part_Of indicator specified. The
3447 -- Part_Of indicator must denote a state declared by either the
3448 -- parent unit of the private unit or by a public descendant of
3449 -- that parent unit.
3451 -- Find the nearest private ancestor (which can be the current
3454 Parent_Unit
:= Pack_Id
;
3455 while Present
(Parent_Unit
) loop
3456 exit when Is_Private_Library_Unit
(Parent_Unit
);
3457 Parent_Unit
:= Scope
(Parent_Unit
);
3460 Parent_Unit
:= Scope
(Parent_Unit
);
3462 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3464 ("indicator Part_Of must denote abstract state of & or of "
3465 & "its public descendant (SPARK RM 7.2.6(3))",
3466 Indic
, Parent_Unit
);
3469 elsif Scope
(Encap_Id
) = Parent_Unit
3471 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3472 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3478 ("indicator Part_Of must denote abstract state of & or of "
3479 & "its public descendant (SPARK RM 7.2.6(3))",
3480 Indic
, Parent_Unit
);
3484 -- Indicator Part_Of is not needed when the related package is
3485 -- not a nongeneric private child unit or a public descendant
3490 ("indicator Part_Of cannot appear in this context "
3491 & "(SPARK RM 7.2.6(5))", Indic
);
3493 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3495 ("\& is declared in the visible part of package %",
3500 -- When the item appears in the private state space of a package, the
3501 -- encapsulating state must be declared in the same package.
3503 elsif Placement
= Private_State_Space
then
3505 -- In the case of the abstract state of a nongeneric private
3506 -- child package, it may be encapsulated in the state of a
3507 -- public descendant of its parent package.
3510 function Is_Public_Descendant
3511 (Child
, Ancestor
: Entity_Id
)
3513 -- Return True if Child is a public descendant of Pack
3515 --------------------------
3516 -- Is_Public_Descendant --
3517 --------------------------
3519 function Is_Public_Descendant
3520 (Child
, Ancestor
: Entity_Id
)
3523 P
: Entity_Id
:= Child
;
3525 while Is_Child_Unit
(P
)
3526 and then not Is_Private_Library_Unit
(P
)
3528 if Scope
(P
) = Ancestor
then
3536 end Is_Public_Descendant
;
3540 Immediate_Pack_Id
: constant Entity_Id
:= Scope
(Item_Id
);
3542 Is_State_Of_Private_Child
: constant Boolean :=
3543 Is_Child_Unit
(Immediate_Pack_Id
)
3544 and then not Is_Generic_Unit
(Immediate_Pack_Id
)
3545 and then Is_Private_Descendant
(Immediate_Pack_Id
);
3547 Is_OK_Through_Sibling
: Boolean := False;
3550 if Ekind
(Item_Id
) = E_Abstract_State
3551 and then Is_State_Of_Private_Child
3552 and then Is_Public_Descendant
(Scope
(Encap_Id
), Pack_Id
)
3554 Is_OK_Through_Sibling
:= True;
3557 if Scope
(Encap_Id
) /= Pack_Id
3558 and then not Is_OK_Through_Sibling
3560 if Is_State_Of_Private_Child
then
3562 ("indicator Part_Of must denote abstract state of & "
3563 & "or of its public descendant "
3564 & "(SPARK RM 7.2.6(3))", Indic
, Pack_Id
);
3567 ("indicator Part_Of must denote an abstract state of "
3568 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3571 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3573 ("\& is declared in the private part of package %",
3579 -- Items declared in the body state space of a package do not need
3580 -- Part_Of indicators as the refinement has already been seen.
3584 ("indicator Part_Of cannot appear in this context "
3585 & "(SPARK RM 7.2.6(5))", Indic
);
3587 if Scope
(Encap_Id
) = Pack_Id
then
3588 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3590 ("\& is declared in the body of package %", Indic
, Item_Id
);
3596 -- At this point it is known that the Part_Of indicator is legal
3599 end Check_Part_Of_Abstract_State
;
3601 -----------------------------------
3602 -- Check_Part_Of_Concurrent_Type --
3603 -----------------------------------
3605 procedure Check_Part_Of_Concurrent_Type
is
3606 function In_Proper_Order
3608 Second
: Node_Id
) return Boolean;
3609 pragma Inline
(In_Proper_Order
);
3610 -- Determine whether node First precedes node Second
3612 procedure Placement_Error
;
3613 pragma Inline
(Placement_Error
);
3614 -- Emit an error concerning the illegal placement of the item with
3615 -- respect to the single concurrent type.
3617 ---------------------
3618 -- In_Proper_Order --
3619 ---------------------
3621 function In_Proper_Order
3623 Second
: Node_Id
) return Boolean
3628 if List_Containing
(First
) = List_Containing
(Second
) then
3630 while Present
(N
) loop
3640 end In_Proper_Order
;
3642 ---------------------
3643 -- Placement_Error --
3644 ---------------------
3646 procedure Placement_Error
is
3649 ("indicator Part_Of must denote a previously declared single "
3650 & "protected type or single task type", Encap
);
3651 end Placement_Error
;
3655 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3656 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3657 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3659 Item_Context
: Node_Id
;
3660 Item_Decl
: Node_Id
;
3661 Prv_Decls
: List_Id
;
3662 Vis_Decls
: List_Id
;
3664 -- Start of processing for Check_Part_Of_Concurrent_Type
3667 -- Only abstract states and variables can act as constituents of an
3668 -- encapsulating single concurrent type.
3670 if Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
3673 -- The constituent is a constant
3675 elsif Ekind
(Item_Id
) = E_Constant
then
3676 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3678 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3679 & "single protected type %"), Indic
, Item_Id
);
3682 -- The constituent is a package instantiation
3685 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3687 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3688 & "constituent of single protected type %"), Indic
, Item_Id
);
3692 -- When the item denotes an abstract state of a nested package, use
3693 -- the declaration of the package to detect proper placement.
3698 -- with Abstract_State => (State with Part_Of => T)
3700 if Ekind
(Item_Id
) = E_Abstract_State
then
3701 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3703 Item_Decl
:= Declaration_Node
(Item_Id
);
3706 Item_Context
:= Parent
(Item_Decl
);
3708 -- The item and the single concurrent type must appear in the same
3709 -- declarative region, with the item following the declaration of
3710 -- the single concurrent type (SPARK RM 9(3)).
3712 if Item_Context
= Encap_Context
then
3713 if Nkind
(Item_Context
) in N_Package_Specification
3714 | N_Protected_Definition
3717 Prv_Decls
:= Private_Declarations
(Item_Context
);
3718 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3720 -- The placement is OK when the single concurrent type appears
3721 -- within the visible declarations and the item in the private
3727 -- Constit : ... with Part_Of => PO;
3730 if List_Containing
(Encap_Decl
) = Vis_Decls
3731 and then List_Containing
(Item_Decl
) = Prv_Decls
3735 -- The placement is illegal when the item appears within the
3736 -- visible declarations and the single concurrent type is in
3737 -- the private declarations.
3740 -- Constit : ... with Part_Of => PO;
3745 elsif List_Containing
(Item_Decl
) = Vis_Decls
3746 and then List_Containing
(Encap_Decl
) = Prv_Decls
3751 -- Otherwise both the item and the single concurrent type are
3752 -- in the same list. Ensure that the declaration of the single
3753 -- concurrent type precedes that of the item.
3755 elsif not In_Proper_Order
3756 (First
=> Encap_Decl
,
3757 Second
=> Item_Decl
)
3763 -- Otherwise both the item and the single concurrent type are
3764 -- in the same list. Ensure that the declaration of the single
3765 -- concurrent type precedes that of the item.
3767 elsif not In_Proper_Order
3768 (First
=> Encap_Decl
,
3769 Second
=> Item_Decl
)
3775 -- Otherwise the item and the single concurrent type reside within
3776 -- unrelated regions.
3779 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3781 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3782 & "immediately within the same region as single protected "
3783 & "type %"), Indic
, Item_Id
);
3787 -- At this point it is known that the Part_Of indicator is legal
3790 end Check_Part_Of_Concurrent_Type
;
3792 -- Start of processing for Analyze_Part_Of
3795 -- Assume that the indicator is illegal
3801 N_Expanded_Name | N_Identifier | N_Selected_Component
3804 Resolve_State
(Encap
);
3806 Encap_Id
:= Entity
(Encap
);
3808 -- The encapsulator is an abstract state
3810 if Ekind
(Encap_Id
) = E_Abstract_State
then
3813 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3815 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3818 -- Otherwise the encapsulator is not a legal choice
3822 ("indicator Part_Of must denote abstract state, single "
3823 & "protected type or single task type", Encap
);
3827 -- This is a syntax error, always report
3831 ("indicator Part_Of must denote abstract state, single protected "
3832 & "type or single task type", Encap
);
3836 -- Catch a case where indicator Part_Of denotes the abstract view of a
3837 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3839 if From_Limited_With
(Encap_Id
)
3840 and then Present
(Non_Limited_View
(Encap_Id
))
3841 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3843 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3844 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3848 -- The encapsulator is an abstract state
3850 if Ekind
(Encap_Id
) = E_Abstract_State
then
3851 Check_Part_Of_Abstract_State
;
3853 -- The encapsulator is a single concurrent type
3856 Check_Part_Of_Concurrent_Type
;
3858 end Analyze_Part_Of
;
3860 ----------------------------------
3861 -- Analyze_Part_Of_In_Decl_Part --
3862 ----------------------------------
3864 procedure Analyze_Part_Of_In_Decl_Part
3866 Freeze_Id
: Entity_Id
:= Empty
)
3868 Encap
: constant Node_Id
:=
3869 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3870 Errors
: constant Nat
:= Serious_Errors_Detected
;
3871 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3872 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3873 Constits
: Elist_Id
;
3874 Encap_Id
: Entity_Id
;
3878 -- Detect any discrepancies between the placement of the variable with
3879 -- respect to general state space and the encapsulating state or single
3886 Encap_Id
=> Encap_Id
,
3889 -- The Part_Of indicator turns the variable into a constituent of the
3890 -- encapsulating state or single concurrent type.
3893 pragma Assert
(Present
(Encap_Id
));
3894 Constits
:= Part_Of_Constituents
(Encap_Id
);
3896 if No
(Constits
) then
3897 Constits
:= New_Elmt_List
;
3898 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3901 Append_Elmt
(Var_Id
, Constits
);
3902 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3904 -- A Part_Of constituent partially refines an abstract state. This
3905 -- property does not apply to protected or task units.
3907 if Ekind
(Encap_Id
) = E_Abstract_State
then
3908 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3912 -- Emit a clarification message when the encapsulator is undefined,
3913 -- possibly due to contract freezing.
3915 if Errors
/= Serious_Errors_Detected
3916 and then Present
(Freeze_Id
)
3917 and then Has_Undefined_Reference
(Encap
)
3919 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3921 end Analyze_Part_Of_In_Decl_Part
;
3923 --------------------
3924 -- Analyze_Pragma --
3925 --------------------
3927 procedure Analyze_Pragma
(N
: Node_Id
) is
3928 Loc
: constant Source_Ptr
:= Sloc
(N
);
3930 Pname
: Name_Id
:= Pragma_Name
(N
);
3931 -- Name of the source pragma, or name of the corresponding aspect for
3932 -- pragmas which originate in a source aspect. In the latter case, the
3933 -- name may be different from the pragma name.
3935 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3937 Pragma_Exit
: exception;
3938 -- This exception is used to exit pragma processing completely. It
3939 -- is used when an error is detected, and no further processing is
3940 -- required. It is also used if an earlier error has left the tree in
3941 -- a state where the pragma should not be processed.
3944 -- Number of pragma argument associations
3951 -- First five pragma arguments (pragma argument association nodes, or
3952 -- Empty if the corresponding argument does not exist).
3954 type Name_List
is array (Natural range <>) of Name_Id
;
3955 type Args_List
is array (Natural range <>) of Node_Id
;
3956 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3958 -----------------------
3959 -- Local Subprograms --
3960 -----------------------
3962 procedure Ada_2005_Pragma
;
3963 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3964 -- Ada 95 mode, these are implementation defined pragmas, so should be
3965 -- caught by the No_Implementation_Pragmas restriction.
3967 procedure Ada_2012_Pragma
;
3968 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3969 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3970 -- should be caught by the No_Implementation_Pragmas restriction.
3972 procedure Analyze_Depends_Global
3973 (Spec_Id
: out Entity_Id
;
3974 Subp_Decl
: out Node_Id
;
3975 Legal
: out Boolean);
3976 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3977 -- legality of the placement and related context of the pragma. Spec_Id
3978 -- is the entity of the related subprogram. Subp_Decl is the declaration
3979 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3981 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3982 -- Inspect the remainder of the list containing pragma N and look for
3983 -- a pragma that matches Id. If found, analyze the pragma.
3985 procedure Analyze_Pre_Post_Condition
;
3986 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3988 procedure Analyze_Refined_Depends_Global_Post
3989 (Spec_Id
: out Entity_Id
;
3990 Body_Id
: out Entity_Id
;
3991 Legal
: out Boolean);
3992 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3993 -- Refined_Global and Refined_Post. Verify the legality of the placement
3994 -- and related context of the pragma. Spec_Id is the entity of the
3995 -- related subprogram. Body_Id is the entity of the subprogram body.
3996 -- Flag Legal is set when the pragma is legal.
3998 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3999 -- Perform full analysis of pragma Unmodified and the write aspect of
4000 -- pragma Unused. Flag Is_Unused should be set when verifying the
4001 -- semantics of pragma Unused.
4003 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
4004 -- Perform full analysis of pragma Unreferenced and the read aspect of
4005 -- pragma Unused. Flag Is_Unused should be set when verifying the
4006 -- semantics of pragma Unused.
4008 procedure Check_Ada_83_Warning
;
4009 -- Issues a warning message for the current pragma if operating in Ada
4010 -- 83 mode (used for language pragmas that are not a standard part of
4011 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
4014 procedure Check_Arg_Count
(Required
: Nat
);
4015 -- Check argument count for pragma is equal to given parameter. If not,
4016 -- then issue an error message and raise Pragma_Exit.
4018 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
4019 -- Arg which can either be a pragma argument association, in which case
4020 -- the check is applied to the expression of the association or an
4021 -- expression directly.
4023 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
4024 -- Check that an argument has the right form for an EXTERNAL_NAME
4025 -- parameter of an extended import/export pragma. The rule is that the
4026 -- name must be an identifier or string literal (in Ada 83 mode) or a
4027 -- static string expression (in Ada 95 mode).
4029 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
4030 -- Check the specified argument Arg to make sure that it is an
4031 -- identifier. If not give error and raise Pragma_Exit.
4033 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
4034 -- Check the specified argument Arg to make sure that it is an integer
4035 -- literal. If not give error and raise Pragma_Exit.
4037 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
4038 -- Check the specified argument Arg to make sure that it has the proper
4039 -- syntactic form for a local name and meets the semantic requirements
4040 -- for a local name. The local name is analyzed as part of the
4041 -- processing for this call. In addition, the local name is required
4042 -- to represent an entity at the library level.
4044 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
4045 -- Check the specified argument Arg to make sure that it has the proper
4046 -- syntactic form for a local name and meets the semantic requirements
4047 -- for a local name. The local name is analyzed as part of the
4048 -- processing for this call.
4050 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
4051 -- Check the specified argument Arg to make sure that it is a valid
4052 -- locking policy name. If not give error and raise Pragma_Exit.
4054 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
4055 -- Check the specified argument Arg to make sure that it is a valid
4056 -- elaboration policy name. If not give error and raise Pragma_Exit.
4058 procedure Check_Arg_Is_One_Of
4061 procedure Check_Arg_Is_One_Of
4063 N1
, N2
, N3
: Name_Id
);
4064 procedure Check_Arg_Is_One_Of
4066 N1
, N2
, N3
, N4
: Name_Id
);
4067 procedure Check_Arg_Is_One_Of
4069 N1
, N2
, N3
, N4
, N5
: Name_Id
);
4070 -- Check the specified argument Arg to make sure that it is an
4071 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
4072 -- present). If not then give error and raise Pragma_Exit.
4074 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
4075 -- Check the specified argument Arg to make sure that it is a valid
4076 -- queuing policy name. If not give error and raise Pragma_Exit.
4078 procedure Check_Arg_Is_OK_Static_Expression
4080 Typ
: Entity_Id
:= Empty
);
4081 -- Check the specified argument Arg to make sure that it is a static
4082 -- expression of the given type (i.e. it will be analyzed and resolved
4083 -- using this type, which can be any valid argument to Resolve, e.g.
4084 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4085 -- Typ is left Empty, then any static expression is allowed. Includes
4086 -- checking that the argument does not raise Constraint_Error.
4088 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
4089 -- Check the specified argument Arg to make sure that it is a valid task
4090 -- dispatching policy name. If not give error and raise Pragma_Exit.
4092 procedure Check_Arg_Order
(Names
: Name_List
);
4093 -- Checks for an instance of two arguments with identifiers for the
4094 -- current pragma which are not in the sequence indicated by Names,
4095 -- and if so, generates a fatal message about bad order of arguments.
4097 procedure Check_At_Least_N_Arguments
(N
: Nat
);
4098 -- Check there are at least N arguments present
4100 procedure Check_At_Most_N_Arguments
(N
: Nat
);
4101 -- Check there are no more than N arguments present
4103 procedure Check_Component
4106 In_Variant_Part
: Boolean := False);
4107 -- Examine an Unchecked_Union component for correct use of per-object
4108 -- constrained subtypes, and for restrictions on finalizable components.
4109 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
4110 -- should be set when Comp comes from a record variant.
4112 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
4113 -- Check if a rep item of the same name as the current pragma is already
4114 -- chained as a rep pragma to the given entity. If so give a message
4115 -- about the duplicate, and then raise Pragma_Exit so does not return.
4116 -- Note that if E is a type, then this routine avoids flagging a pragma
4117 -- which applies to a parent type from which E is derived.
4119 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
4120 -- Nam is an N_String_Literal node containing the external name set by
4121 -- an Import or Export pragma (or extended Import or Export pragma).
4122 -- This procedure checks for possible duplications if this is the export
4123 -- case, and if found, issues an appropriate error message.
4125 procedure Check_Expr_Is_OK_Static_Expression
4127 Typ
: Entity_Id
:= Empty
);
4128 -- Check the specified expression Expr to make sure that it is a static
4129 -- expression of the given type (i.e. it will be analyzed and resolved
4130 -- using this type, which can be any valid argument to Resolve, e.g.
4131 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
4132 -- Typ is left Empty, then any static expression is allowed. Includes
4133 -- checking that the expression does not raise Constraint_Error.
4135 procedure Check_First_Subtype
(Arg
: Node_Id
);
4136 -- Checks that Arg, whose expression is an entity name, references a
4139 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4140 -- Checks that the given argument has an identifier, and if so, requires
4141 -- it to match the given identifier name. If there is no identifier, or
4142 -- a non-matching identifier, then an error message is given and
4143 -- Pragma_Exit is raised.
4145 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
4146 -- Checks that the given argument has an identifier, and if so, requires
4147 -- it to match one of the given identifier names. If there is no
4148 -- identifier, or a non-matching identifier, then an error message is
4149 -- given and Pragma_Exit is raised.
4151 procedure Check_In_Main_Program
;
4152 -- Common checks for pragmas that appear within a main program
4153 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
4155 procedure Check_Interrupt_Or_Attach_Handler
;
4156 -- Common processing for first argument of pragma Interrupt_Handler or
4157 -- pragma Attach_Handler.
4159 procedure Check_Loop_Pragma_Placement
;
4160 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
4161 -- appear immediately within a construct restricted to loops, and that
4162 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
4164 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
4165 -- Check that pragma appears in a declarative part, or in a package
4166 -- specification, i.e. that it does not occur in a statement sequence
4169 procedure Check_No_Identifier
(Arg
: Node_Id
);
4170 -- Checks that the given argument does not have an identifier. If
4171 -- an identifier is present, then an error message is issued, and
4172 -- Pragma_Exit is raised.
4174 procedure Check_No_Identifiers
;
4175 -- Checks that none of the arguments to the pragma has an identifier.
4176 -- If any argument has an identifier, then an error message is issued,
4177 -- and Pragma_Exit is raised.
4179 procedure Check_No_Link_Name
;
4180 -- Checks that no link name is specified
4182 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
4183 -- Checks if the given argument has an identifier, and if so, requires
4184 -- it to match the given identifier name. If there is a non-matching
4185 -- identifier, then an error message is given and Pragma_Exit is raised.
4187 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
4188 -- Checks if the given argument has an identifier, and if so, requires
4189 -- it to match the given identifier name. If there is a non-matching
4190 -- identifier, then an error message is given and Pragma_Exit is raised.
4191 -- In this version of the procedure, the identifier name is given as
4192 -- a string with lower case letters.
4194 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
4195 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
4196 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
4197 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
4198 -- is an OK static boolean expression. Emit an error if this is not the
4201 procedure Check_Static_Constraint
(Constr
: Node_Id
);
4202 -- Constr is a constraint from an N_Subtype_Indication node from a
4203 -- component constraint in an Unchecked_Union type, a range, or a
4204 -- discriminant association. This routine checks that the constraint
4205 -- is static as required by the restrictions for Unchecked_Union.
4207 procedure Check_Valid_Configuration_Pragma
;
4208 -- Legality checks for placement of a configuration pragma
4210 procedure Check_Valid_Library_Unit_Pragma
;
4211 -- Legality checks for library unit pragmas. A special case arises for
4212 -- pragmas in generic instances that come from copies of the original
4213 -- library unit pragmas in the generic templates. In the case of other
4214 -- than library level instantiations these can appear in contexts which
4215 -- would normally be invalid (they only apply to the original template
4216 -- and to library level instantiations), and they are simply ignored,
4217 -- which is implemented by rewriting them as null statements and
4218 -- optionally raising Pragma_Exit to terminate analysis. An exception
4219 -- is not always raised to avoid exception propagation during the
4220 -- bootstrap, so all callers should check whether N has been rewritten.
4222 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
4223 -- Check an Unchecked_Union variant for lack of nested variants and
4224 -- presence of at least one component. UU_Typ is the related Unchecked_
4227 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
4228 -- Subsidiary routine to the processing of pragmas Abstract_State,
4229 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
4230 -- Refined_Global, Refined_State and Subprogram_Variant. Transform
4231 -- argument Arg into an aggregate if not one already. N_Null is never
4232 -- transformed. Arg may denote an aspect specification or a pragma
4233 -- argument association.
4235 procedure Error_Pragma
(Msg
: String);
4236 pragma No_Return
(Error_Pragma
);
4237 -- Outputs error message for current pragma. The message contains a %
4238 -- that will be replaced with the pragma name, and the flag is placed
4239 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
4240 -- calls Fix_Error (see spec of that procedure for details).
4242 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
4243 pragma No_Return
(Error_Pragma_Arg
);
4244 -- Outputs error message for current pragma. The message may contain
4245 -- a % that will be replaced with the pragma name. The parameter Arg
4246 -- may either be a pragma argument association, in which case the flag
4247 -- is placed on the expression of this association, or an expression,
4248 -- in which case the flag is placed directly on the expression. The
4249 -- message is placed using Error_Msg_N, so the message may also contain
4250 -- an & insertion character which will reference the given Arg value.
4251 -- After placing the message, Pragma_Exit is raised. Note: this routine
4252 -- calls Fix_Error (see spec of that procedure for details).
4254 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
4255 pragma No_Return
(Error_Pragma_Arg
);
4256 -- Similar to above form of Error_Pragma_Arg except that two messages
4257 -- are provided, the second is a continuation comment starting with \.
4259 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
4260 pragma No_Return
(Error_Pragma_Arg_Ident
);
4261 -- Outputs error message for current pragma. The message may contain a %
4262 -- that will be replaced with the pragma name. The parameter Arg must be
4263 -- a pragma argument association with a non-empty identifier (i.e. its
4264 -- Chars field must be set), and the error message is placed on the
4265 -- identifier. The message is placed using Error_Msg_N so the message
4266 -- may also contain an & insertion character which will reference
4267 -- the identifier. After placing the message, Pragma_Exit is raised.
4268 -- Note: this routine calls Fix_Error (see spec of that procedure for
4271 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4272 pragma No_Return
(Error_Pragma_Ref
);
4273 -- Outputs error message for current pragma. The message may contain
4274 -- a % that will be replaced with the pragma name. The parameter Ref
4275 -- must be an entity whose name can be referenced by & and sloc by #.
4276 -- After placing the message, Pragma_Exit is raised. Note: this routine
4277 -- calls Fix_Error (see spec of that procedure for details).
4279 function Find_Lib_Unit_Name
return Entity_Id
;
4280 -- Used for a library unit pragma to find the entity to which the
4281 -- library unit pragma applies, returns the entity found.
4283 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4284 -- If the pragma is a compilation unit pragma, the id must denote the
4285 -- compilation unit in the same compilation, and the pragma must appear
4286 -- in the list of preceding or trailing pragmas. If it is a program
4287 -- unit pragma that is not a compilation unit pragma, then the
4288 -- identifier must be visible.
4290 function Find_Unique_Parameterless_Procedure
4292 Arg
: Node_Id
) return Entity_Id
;
4293 -- Used for a procedure pragma to find the unique parameterless
4294 -- procedure identified by Name, returns it if it exists, otherwise
4295 -- errors out and uses Arg as the pragma argument for the message.
4297 function Fix_Error
(Msg
: String) return String;
4298 -- This is called prior to issuing an error message. Msg is the normal
4299 -- error message issued in the pragma case. This routine checks for the
4300 -- case of a pragma coming from an aspect in the source, and returns a
4301 -- message suitable for the aspect case as follows:
4303 -- Each substring "pragma" is replaced by "aspect"
4305 -- If "argument of" is at the start of the error message text, it is
4306 -- replaced by "entity for".
4308 -- If "argument" is at the start of the error message text, it is
4309 -- replaced by "entity".
4311 -- So for example, "argument of pragma X must be discrete type"
4312 -- returns "entity for aspect X must be a discrete type".
4314 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4315 -- be different from the pragma name). If the current pragma results
4316 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4317 -- original pragma name.
4319 procedure Gather_Associations
4321 Args
: out Args_List
);
4322 -- This procedure is used to gather the arguments for a pragma that
4323 -- permits arbitrary ordering of parameters using the normal rules
4324 -- for named and positional parameters. The Names argument is a list
4325 -- of Name_Id values that corresponds to the allowed pragma argument
4326 -- association identifiers in order. The result returned in Args is
4327 -- a list of corresponding expressions that are the pragma arguments.
4328 -- Note that this is a list of expressions, not of pragma argument
4329 -- associations (Gather_Associations has completely checked all the
4330 -- optional identifiers when it returns). An entry in Args is Empty
4331 -- on return if the corresponding argument is not present.
4333 procedure GNAT_Pragma
;
4334 -- Called for all GNAT defined pragmas to check the relevant restriction
4335 -- (No_Implementation_Pragmas).
4337 function Is_Before_First_Decl
4338 (Pragma_Node
: Node_Id
;
4339 Decls
: List_Id
) return Boolean;
4340 -- Return True if Pragma_Node is before the first declarative item in
4341 -- Decls where Decls is the list of declarative items.
4343 function Is_Configuration_Pragma
return Boolean;
4344 -- Determines if the placement of the current pragma is appropriate
4345 -- for a configuration pragma.
4347 function Is_In_Context_Clause
return Boolean;
4348 -- Returns True if pragma appears within the context clause of a unit,
4349 -- and False for any other placement (does not generate any messages).
4351 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4352 -- Analyzes the argument, and determines if it is a static string
4353 -- expression, returns True if so, False if non-static or not String.
4354 -- A special case is that a string literal returns True in Ada 83 mode
4355 -- (which has no such thing as static string expressions). Note that
4356 -- the call analyzes its argument, so this cannot be used for the case
4357 -- where an identifier might not be declared.
4359 procedure Pragma_Misplaced
;
4360 pragma No_Return
(Pragma_Misplaced
);
4361 -- Issue fatal error message for misplaced pragma
4363 procedure Process_Atomic_Independent_Shared_Volatile
;
4364 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4365 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4366 -- and treated as being identical in effect to pragma Atomic.
4368 procedure Process_Compile_Time_Warning_Or_Error
;
4369 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4371 procedure Process_Convention
4372 (C
: out Convention_Id
;
4373 Ent
: out Entity_Id
);
4374 -- Common processing for Convention, Interface, Import and Export.
4375 -- Checks first two arguments of pragma, and sets the appropriate
4376 -- convention value in the specified entity or entities. On return
4377 -- C is the convention, Ent is the referenced entity.
4379 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4380 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4381 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4383 procedure Process_Extended_Import_Export_Object_Pragma
4384 (Arg_Internal
: Node_Id
;
4385 Arg_External
: Node_Id
;
4386 Arg_Size
: Node_Id
);
4387 -- Common processing for the pragmas Import/Export_Object. The three
4388 -- arguments correspond to the three named parameters of the pragmas. An
4389 -- argument is empty if the corresponding parameter is not present in
4392 procedure Process_Extended_Import_Export_Internal_Arg
4393 (Arg_Internal
: Node_Id
:= Empty
);
4394 -- Common processing for all extended Import and Export pragmas. The
4395 -- argument is the pragma parameter for the Internal argument. If
4396 -- Arg_Internal is empty or inappropriate, an error message is posted.
4397 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4398 -- set to identify the referenced entity.
4400 procedure Process_Extended_Import_Export_Subprogram_Pragma
4401 (Arg_Internal
: Node_Id
;
4402 Arg_External
: Node_Id
;
4403 Arg_Parameter_Types
: Node_Id
;
4404 Arg_Result_Type
: Node_Id
:= Empty
;
4405 Arg_Mechanism
: Node_Id
;
4406 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4407 -- Common processing for all extended Import and Export pragmas applying
4408 -- to subprograms. The caller omits any arguments that do not apply to
4409 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4410 -- only in the Import_Function and Export_Function cases). The argument
4411 -- names correspond to the allowed pragma association identifiers.
4413 procedure Process_Generic_List
;
4414 -- Common processing for Share_Generic and Inline_Generic
4416 procedure Process_Import_Or_Interface
;
4417 -- Common processing for Import or Interface
4419 procedure Process_Import_Predefined_Type
;
4420 -- Processing for completing a type with pragma Import. This is used
4421 -- to declare types that match predefined C types, especially for cases
4422 -- without corresponding Ada predefined type.
4424 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4425 -- Inline status of a subprogram, indicated as follows:
4426 -- Suppressed: inlining is suppressed for the subprogram
4427 -- Disabled: no inlining is requested for the subprogram
4428 -- Enabled: inlining is requested/required for the subprogram
4430 procedure Process_Inline
(Status
: Inline_Status
);
4431 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4432 -- indicates the inline status specified by the pragma.
4434 procedure Process_Interface_Name
4435 (Subprogram_Def
: Entity_Id
;
4439 -- Given the last two arguments of pragma Import, pragma Export, or
4440 -- pragma Interface_Name, performs validity checks and sets the
4441 -- Interface_Name field of the given subprogram entity to the
4442 -- appropriate external or link name, depending on the arguments given.
4443 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4444 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4445 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4446 -- nor Link_Arg is present, the interface name is set to the default
4447 -- from the subprogram name. In addition, the pragma itself is passed
4448 -- to analyze any expressions in the case the pragma came from an aspect
4451 procedure Process_Interrupt_Or_Attach_Handler
;
4452 -- Common processing for Interrupt and Attach_Handler pragmas
4454 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4455 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4456 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4457 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4458 -- is not set in the Restrictions case.
4460 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4461 -- Common processing for Suppress and Unsuppress. The boolean parameter
4462 -- Suppress_Case is True for the Suppress case, and False for the
4465 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4466 -- Subsidiary to the analysis of pragmas Independent[_Components].
4467 -- Record such a pragma N applied to entity E for future checks.
4469 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4470 -- This procedure sets the Is_Exported flag for the given entity,
4471 -- checking that the entity was not previously imported. Arg is
4472 -- the argument that specified the entity. A check is also made
4473 -- for exporting inappropriate entities.
4475 procedure Set_Extended_Import_Export_External_Name
4476 (Internal_Ent
: Entity_Id
;
4477 Arg_External
: Node_Id
);
4478 -- Common processing for all extended import export pragmas. The first
4479 -- argument, Internal_Ent, is the internal entity, which has already
4480 -- been checked for validity by the caller. Arg_External is from the
4481 -- Import or Export pragma, and may be null if no External parameter
4482 -- was present. If Arg_External is present and is a non-null string
4483 -- (a null string is treated as the default), then the Interface_Name
4484 -- field of Internal_Ent is set appropriately.
4486 procedure Set_Imported
(E
: Entity_Id
);
4487 -- This procedure sets the Is_Imported flag for the given entity,
4488 -- checking that it is not previously exported or imported.
4490 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4491 -- Mech is a parameter passing mechanism (see Import_Function syntax
4492 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4493 -- has the right form, and if not issues an error message. If the
4494 -- argument has the right form then the Mechanism field of Ent is
4495 -- set appropriately.
4497 procedure Set_Rational_Profile
;
4498 -- Activate the set of configuration pragmas and permissions that make
4499 -- up the Rational profile.
4501 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4502 -- Activate the set of configuration pragmas and restrictions that make
4503 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4504 -- GNAT_Ravenscar_EDF, Jorvik, or Ravenscar. N is the corresponding
4505 -- pragma node, which is used for error messages on any constructs
4506 -- violating the profile.
4508 ---------------------
4509 -- Ada_2005_Pragma --
4510 ---------------------
4512 procedure Ada_2005_Pragma
is
4514 if Ada_Version
<= Ada_95
then
4515 Check_Restriction
(No_Implementation_Pragmas
, N
);
4517 end Ada_2005_Pragma
;
4519 ---------------------
4520 -- Ada_2012_Pragma --
4521 ---------------------
4523 procedure Ada_2012_Pragma
is
4525 if Ada_Version
<= Ada_2005
then
4526 Check_Restriction
(No_Implementation_Pragmas
, N
);
4528 end Ada_2012_Pragma
;
4530 ----------------------------
4531 -- Analyze_Depends_Global --
4532 ----------------------------
4534 procedure Analyze_Depends_Global
4535 (Spec_Id
: out Entity_Id
;
4536 Subp_Decl
: out Node_Id
;
4537 Legal
: out Boolean)
4540 -- Assume that the pragma is illegal
4547 Check_Arg_Count
(1);
4549 -- Ensure the proper placement of the pragma. Depends/Global must be
4550 -- associated with a subprogram declaration or a body that acts as a
4553 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4557 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4560 -- Generic subprogram
4562 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4565 -- Object declaration of a single concurrent type
4567 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4568 and then Is_Single_Concurrent_Object
4569 (Unique_Defining_Entity
(Subp_Decl
))
4575 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4578 -- Subprogram body acts as spec
4580 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4581 and then No
(Corresponding_Spec
(Subp_Decl
))
4585 -- Subprogram body stub acts as spec
4587 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4588 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4592 -- Subprogram declaration
4594 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4596 -- Pragmas Global and Depends are forbidden on null procedures
4597 -- (SPARK RM 6.1.2(2)).
4599 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4600 and then Null_Present
(Specification
(Subp_Decl
))
4602 Error_Msg_N
(Fix_Error
4603 ("pragma % cannot apply to null procedure"), N
);
4609 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
4631 -- When the related context is an anonymous object created for a
4632 -- simple concurrent type, the type must be a task
4633 -- (SPARK RM 6.1.4(6)).
4635 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4636 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4642 -- A pragma that applies to a Ghost entity becomes Ghost for the
4643 -- purposes of legality checks and removal of ignored Ghost code.
4645 Mark_Ghost_Pragma
(N
, Spec_Id
);
4646 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4647 end Analyze_Depends_Global
;
4649 ------------------------
4650 -- Analyze_If_Present --
4651 ------------------------
4653 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4657 pragma Assert
(Is_List_Member
(N
));
4659 -- Inspect the declarations or statements following pragma N looking
4660 -- for another pragma whose Id matches the caller's request. If it is
4661 -- available, analyze it.
4664 while Present
(Stmt
) loop
4665 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4666 Analyze_Pragma
(Stmt
);
4669 -- The first source declaration or statement immediately following
4670 -- N ends the region where a pragma may appear.
4672 elsif Comes_From_Source
(Stmt
) then
4678 end Analyze_If_Present
;
4680 --------------------------------
4681 -- Analyze_Pre_Post_Condition --
4682 --------------------------------
4684 procedure Analyze_Pre_Post_Condition
is
4685 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4686 Subp_Decl
: Node_Id
;
4687 Subp_Id
: Entity_Id
;
4689 Duplicates_OK
: Boolean := False;
4690 -- Flag set when a pre/postcondition allows multiple pragmas of the
4693 In_Body_OK
: Boolean := False;
4694 -- Flag set when a pre/postcondition is allowed to appear on a body
4695 -- even though the subprogram may have a spec.
4697 Is_Pre_Post
: Boolean := False;
4698 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4701 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4702 -- Implement rules in AI12-0131: an overriding operation can have
4703 -- a class-wide precondition only if one of its ancestors has an
4704 -- explicit class-wide precondition.
4706 -----------------------------
4707 -- Inherits_Class_Wide_Pre --
4708 -----------------------------
4710 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4711 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4714 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4717 -- Check ancestors on the overriding operation to examine the
4718 -- preconditions that may apply to them.
4720 while Present
(Prev
) loop
4721 Cont
:= Contract
(Prev
);
4722 if Present
(Cont
) then
4723 Prag
:= Pre_Post_Conditions
(Cont
);
4724 while Present
(Prag
) loop
4725 if Pragma_Name
(Prag
) = Name_Precondition
4726 and then Class_Present
(Prag
)
4731 Prag
:= Next_Pragma
(Prag
);
4735 -- For a type derived from a generic formal type, the operation
4736 -- inheriting the condition is a renaming, not an overriding of
4737 -- the operation of the formal. Ditto for an inherited
4738 -- operation which has no explicit contracts.
4740 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4741 or else not Comes_From_Source
(Prev
)
4743 Prev
:= Alias
(Prev
);
4745 Prev
:= Overridden_Operation
(Prev
);
4749 -- If the controlling type of the subprogram has progenitors, an
4750 -- interface operation implemented by the current operation may
4751 -- have a class-wide precondition.
4753 if Has_Interfaces
(Typ
) then
4758 Prim_Elmt
: Elmt_Id
;
4759 Prim_List
: Elist_Id
;
4762 Collect_Interfaces
(Typ
, Ints
);
4763 Elmt
:= First_Elmt
(Ints
);
4765 -- Iterate over the primitive operations of each interface
4767 while Present
(Elmt
) loop
4768 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4769 Prim_Elmt
:= First_Elmt
(Prim_List
);
4770 while Present
(Prim_Elmt
) loop
4771 Prim
:= Node
(Prim_Elmt
);
4772 if Chars
(Prim
) = Chars
(E
)
4773 and then Present
(Contract
(Prim
))
4774 and then Class_Present
4775 (Pre_Post_Conditions
(Contract
(Prim
)))
4780 Next_Elmt
(Prim_Elmt
);
4789 end Inherits_Class_Wide_Pre
;
4791 -- Start of processing for Analyze_Pre_Post_Condition
4794 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4795 -- offer uniformity among the various kinds of pre/postconditions by
4796 -- rewriting the pragma identifier. This allows the retrieval of the
4797 -- original pragma name by routine Original_Aspect_Pragma_Name.
4799 if Comes_From_Source
(N
) then
4800 if Pname
in Name_Pre | Name_Pre_Class
then
4801 Is_Pre_Post
:= True;
4802 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4803 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4805 elsif Pname
in Name_Post | Name_Post_Class
then
4806 Is_Pre_Post
:= True;
4807 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4808 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4812 -- Determine the semantics with respect to duplicates and placement
4813 -- in a body. Pragmas Precondition and Postcondition were introduced
4814 -- before aspects and are not subject to the same aspect-like rules.
4816 if Pname
in Name_Precondition | Name_Postcondition
then
4817 Duplicates_OK
:= True;
4823 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4824 -- argument without an identifier.
4827 Check_Arg_Count
(1);
4828 Check_No_Identifiers
;
4830 -- Pragmas Precondition and Postcondition have complex argument
4834 Check_At_Least_N_Arguments
(1);
4835 Check_At_Most_N_Arguments
(2);
4836 Check_Optional_Identifier
(Arg1
, Name_Check
);
4838 if Present
(Arg2
) then
4839 Check_Optional_Identifier
(Arg2
, Name_Message
);
4840 Preanalyze_Spec_Expression
4841 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4845 -- For a pragma PPC in the extended main source unit, record enabled
4847 -- ??? nothing checks that the pragma is in the main source unit
4849 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4850 Set_SCO_Pragma_Enabled
(Loc
);
4853 -- Ensure the proper placement of the pragma
4856 Find_Related_Declaration_Or_Body
4857 (N
, Do_Checks
=> not Duplicates_OK
);
4859 -- When a pre/postcondition pragma applies to an abstract subprogram,
4860 -- its original form must be an aspect with 'Class.
4862 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4863 if not From_Aspect_Specification
(N
) then
4865 ("pragma % cannot be applied to abstract subprogram");
4867 elsif not Class_Present
(N
) then
4869 ("aspect % requires ''Class for abstract subprogram");
4872 -- Entry declaration
4874 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4877 -- Generic subprogram declaration
4879 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4884 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4885 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4889 -- Subprogram body stub
4891 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4892 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4896 -- Subprogram declaration
4898 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4900 -- AI05-0230: When a pre/postcondition pragma applies to a null
4901 -- procedure, its original form must be an aspect with 'Class.
4903 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4904 and then Null_Present
(Specification
(Subp_Decl
))
4905 and then From_Aspect_Specification
(N
)
4906 and then not Class_Present
(N
)
4908 Error_Pragma
("aspect % requires ''Class for null procedure");
4911 -- Implement the legality checks mandated by AI12-0131:
4912 -- Pre'Class shall not be specified for an overriding primitive
4913 -- subprogram of a tagged type T unless the Pre'Class aspect is
4914 -- specified for the corresponding primitive subprogram of some
4918 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4921 if Class_Present
(N
)
4922 and then Pragma_Name
(N
) = Name_Precondition
4923 and then Present
(Overridden_Operation
(E
))
4924 and then not Inherits_Class_Wide_Pre
(E
)
4927 ("illegal class-wide precondition on overriding operation",
4928 Corresponding_Aspect
(N
));
4932 -- A renaming declaration may inherit a generated pragma, its
4933 -- placement comes from expansion, not from source.
4935 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4936 and then not Comes_From_Source
(N
)
4940 -- For Ada 2022, pre/postconditions can appear on formal subprograms
4942 elsif Nkind
(Subp_Decl
) = N_Formal_Concrete_Subprogram_Declaration
4943 and then Ada_Version
>= Ada_2022
4947 -- An access-to-subprogram type can have pre/postconditions, but
4948 -- these are transferred to the generated subprogram wrapper and
4951 -- Otherwise the placement of the pragma is illegal
4958 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4960 -- A pragma that applies to a Ghost entity becomes Ghost for the
4961 -- purposes of legality checks and removal of ignored Ghost code.
4963 Mark_Ghost_Pragma
(N
, Subp_Id
);
4965 -- Chain the pragma on the contract for further processing by
4966 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4968 Add_Contract_Item
(N
, Subp_Id
);
4970 -- Fully analyze the pragma when it appears inside an entry or
4971 -- subprogram body because it cannot benefit from forward references.
4973 if Nkind
(Subp_Decl
) in N_Entry_Body
4975 | N_Subprogram_Body_Stub
4977 -- The legality checks of pragmas Precondition and Postcondition
4978 -- are affected by the SPARK mode in effect and the volatility of
4979 -- the context. Analyze all pragmas in a specific order.
4981 Analyze_If_Present
(Pragma_SPARK_Mode
);
4982 Analyze_If_Present
(Pragma_Volatile_Function
);
4983 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4985 end Analyze_Pre_Post_Condition
;
4987 -----------------------------------------
4988 -- Analyze_Refined_Depends_Global_Post --
4989 -----------------------------------------
4991 procedure Analyze_Refined_Depends_Global_Post
4992 (Spec_Id
: out Entity_Id
;
4993 Body_Id
: out Entity_Id
;
4994 Legal
: out Boolean)
4996 Body_Decl
: Node_Id
;
4997 Spec_Decl
: Node_Id
;
5000 -- Assume that the pragma is illegal
5007 Check_Arg_Count
(1);
5008 Check_No_Identifiers
;
5010 -- Verify the placement of the pragma and check for duplicates. The
5011 -- pragma must apply to a subprogram body [stub].
5013 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
5015 if Nkind
(Body_Decl
) not in
5016 N_Entry_Body | N_Subprogram_Body | N_Subprogram_Body_Stub |
5017 N_Task_Body | N_Task_Body_Stub
5023 Body_Id
:= Defining_Entity
(Body_Decl
);
5024 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
5026 -- The pragma must apply to the second declaration of a subprogram.
5027 -- In other words, the body [stub] cannot acts as a spec.
5029 if No
(Spec_Id
) then
5030 Error_Pragma
("pragma % cannot apply to a stand alone body");
5033 -- Catch the case where the subprogram body is a subunit and acts as
5034 -- the third declaration of the subprogram.
5036 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
5037 Error_Pragma
("pragma % cannot apply to a subunit");
5041 -- A refined pragma can only apply to the body [stub] of a subprogram
5042 -- declared in the visible part of a package. Retrieve the context of
5043 -- the subprogram declaration.
5045 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
5047 -- When dealing with protected entries or protected subprograms, use
5048 -- the enclosing protected type as the proper context.
5050 if Ekind
(Spec_Id
) in E_Entry
5054 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
5056 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
5059 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
5061 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
5062 & "subprogram declared in a package specification"));
5066 -- If we get here, then the pragma is legal
5070 -- A pragma that applies to a Ghost entity becomes Ghost for the
5071 -- purposes of legality checks and removal of ignored Ghost code.
5073 Mark_Ghost_Pragma
(N
, Spec_Id
);
5075 if Pname
in Name_Refined_Depends | Name_Refined_Global
then
5076 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
5078 end Analyze_Refined_Depends_Global_Post
;
5080 ----------------------------------
5081 -- Analyze_Unmodified_Or_Unused --
5082 ----------------------------------
5084 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
5089 Ghost_Error_Posted
: Boolean := False;
5090 -- Flag set when an error concerning the illegal mix of Ghost and
5091 -- non-Ghost variables is emitted.
5093 Ghost_Id
: Entity_Id
:= Empty
;
5094 -- The entity of the first Ghost variable encountered while
5095 -- processing the arguments of the pragma.
5099 Check_At_Least_N_Arguments
(1);
5101 -- Loop through arguments
5104 while Present
(Arg
) loop
5105 Check_No_Identifier
(Arg
);
5107 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5108 -- in fact generate reference, so that the entity will have a
5109 -- reference, which will inhibit any warnings about it not
5110 -- being referenced, and also properly show up in the ali file
5111 -- as a reference. But this reference is recorded before the
5112 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5113 -- generated for this reference.
5115 Check_Arg_Is_Local_Name
(Arg
);
5116 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5118 if Is_Entity_Name
(Arg_Expr
) then
5119 Arg_Id
:= Entity
(Arg_Expr
);
5121 -- Skip processing the argument if already flagged
5123 if Is_Assignable
(Arg_Id
)
5124 and then not Has_Pragma_Unmodified
(Arg_Id
)
5125 and then not Has_Pragma_Unused
(Arg_Id
)
5127 Set_Has_Pragma_Unmodified
(Arg_Id
);
5130 Set_Has_Pragma_Unused
(Arg_Id
);
5133 -- A pragma that applies to a Ghost entity becomes Ghost for
5134 -- the purposes of legality checks and removal of ignored
5137 Mark_Ghost_Pragma
(N
, Arg_Id
);
5139 -- Capture the entity of the first Ghost variable being
5140 -- processed for error detection purposes.
5142 if Is_Ghost_Entity
(Arg_Id
) then
5143 if No
(Ghost_Id
) then
5147 -- Otherwise the variable is non-Ghost. It is illegal to mix
5148 -- references to Ghost and non-Ghost entities
5151 elsif Present
(Ghost_Id
)
5152 and then not Ghost_Error_Posted
5154 Ghost_Error_Posted
:= True;
5156 Error_Msg_Name_1
:= Pname
;
5158 ("pragma % cannot mention ghost and non-ghost "
5161 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5162 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
5164 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5165 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
5168 -- Warn if already flagged as Unused or Unmodified
5170 elsif Has_Pragma_Unmodified
(Arg_Id
) then
5171 if Has_Pragma_Unused
(Arg_Id
) then
5173 ("??pragma Unused already given for &!", Arg_Expr
,
5177 ("??pragma Unmodified already given for &!", Arg_Expr
,
5181 -- Otherwise the pragma referenced an illegal entity
5185 ("pragma% can only be applied to a variable", Arg_Expr
);
5191 end Analyze_Unmodified_Or_Unused
;
5193 ------------------------------------
5194 -- Analyze_Unreferenced_Or_Unused --
5195 ------------------------------------
5197 procedure Analyze_Unreferenced_Or_Unused
5198 (Is_Unused
: Boolean := False)
5205 Ghost_Error_Posted
: Boolean := False;
5206 -- Flag set when an error concerning the illegal mix of Ghost and
5207 -- non-Ghost names is emitted.
5209 Ghost_Id
: Entity_Id
:= Empty
;
5210 -- The entity of the first Ghost name encountered while processing
5211 -- the arguments of the pragma.
5215 Check_At_Least_N_Arguments
(1);
5217 -- Check case of appearing within context clause
5219 if not Is_Unused
and then Is_In_Context_Clause
then
5221 -- The arguments must all be units mentioned in a with clause in
5222 -- the same context clause. Note that Par.Prag already checked
5223 -- that the arguments are either identifiers or selected
5227 while Present
(Arg
) loop
5228 Citem
:= First
(List_Containing
(N
));
5229 while Citem
/= N
loop
5230 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5232 if Nkind
(Citem
) = N_With_Clause
5233 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5235 Set_Has_Pragma_Unreferenced
5238 (Library_Unit
(Citem
))));
5239 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5248 ("argument of pragma% is not withed unit", Arg
);
5254 -- Case of not in list of context items
5258 while Present
(Arg
) loop
5259 Check_No_Identifier
(Arg
);
5261 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5262 -- in fact generate reference, so that the entity will have a
5263 -- reference, which will inhibit any warnings about it not
5264 -- being referenced, and also properly show up in the ali file
5265 -- as a reference. But this reference is recorded before the
5266 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5267 -- generated for this reference.
5269 Check_Arg_Is_Local_Name
(Arg
);
5270 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5272 if Is_Entity_Name
(Arg_Expr
) then
5273 Arg_Id
:= Entity
(Arg_Expr
);
5275 -- Warn if already flagged as Unused or Unreferenced and
5276 -- skip processing the argument.
5278 if Has_Pragma_Unreferenced
(Arg_Id
) then
5279 if Has_Pragma_Unused
(Arg_Id
) then
5281 ("??pragma Unused already given for &!", Arg_Expr
,
5285 ("??pragma Unreferenced already given for &!",
5289 -- Apply Unreferenced to the entity
5292 -- If the entity is overloaded, the pragma applies to the
5293 -- most recent overloading, as documented. In this case,
5294 -- name resolution does not generate a reference, so it
5295 -- must be done here explicitly.
5297 if Is_Overloaded
(Arg_Expr
) then
5298 Generate_Reference
(Arg_Id
, N
);
5301 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5304 Set_Has_Pragma_Unused
(Arg_Id
);
5307 -- A pragma that applies to a Ghost entity becomes Ghost
5308 -- for the purposes of legality checks and removal of
5309 -- ignored Ghost code.
5311 Mark_Ghost_Pragma
(N
, Arg_Id
);
5313 -- Capture the entity of the first Ghost name being
5314 -- processed for error detection purposes.
5316 if Is_Ghost_Entity
(Arg_Id
) then
5317 if No
(Ghost_Id
) then
5321 -- Otherwise the name is non-Ghost. It is illegal to mix
5322 -- references to Ghost and non-Ghost entities
5325 elsif Present
(Ghost_Id
)
5326 and then not Ghost_Error_Posted
5328 Ghost_Error_Posted
:= True;
5330 Error_Msg_Name_1
:= Pname
;
5332 ("pragma % cannot mention ghost and non-ghost "
5335 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5337 ("\& # declared as ghost", N
, Ghost_Id
);
5339 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5341 ("\& # declared as non-ghost", N
, Arg_Id
);
5349 end Analyze_Unreferenced_Or_Unused
;
5351 --------------------------
5352 -- Check_Ada_83_Warning --
5353 --------------------------
5355 procedure Check_Ada_83_Warning
is
5357 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5358 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5360 end Check_Ada_83_Warning
;
5362 ---------------------
5363 -- Check_Arg_Count --
5364 ---------------------
5366 procedure Check_Arg_Count
(Required
: Nat
) is
5368 if Arg_Count
/= Required
then
5369 Error_Pragma
("wrong number of arguments for pragma%");
5371 end Check_Arg_Count
;
5373 --------------------------------
5374 -- Check_Arg_Is_External_Name --
5375 --------------------------------
5377 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5378 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5381 if Nkind
(Argx
) = N_Identifier
then
5385 Analyze_And_Resolve
(Argx
, Standard_String
);
5387 if Is_OK_Static_Expression
(Argx
) then
5390 elsif Etype
(Argx
) = Any_Type
then
5393 -- An interesting special case, if we have a string literal and
5394 -- we are in Ada 83 mode, then we allow it even though it will
5395 -- not be flagged as static. This allows expected Ada 83 mode
5396 -- use of external names which are string literals, even though
5397 -- technically these are not static in Ada 83.
5399 elsif Ada_Version
= Ada_83
5400 and then Nkind
(Argx
) = N_String_Literal
5404 -- Here we have a real error (non-static expression)
5407 Error_Msg_Name_1
:= Pname
;
5408 Flag_Non_Static_Expr
5409 (Fix_Error
("argument for pragma% must be a identifier or "
5410 & "static string expression!"), Argx
);
5415 end Check_Arg_Is_External_Name
;
5417 -----------------------------
5418 -- Check_Arg_Is_Identifier --
5419 -----------------------------
5421 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5422 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5424 if Nkind
(Argx
) /= N_Identifier
then
5425 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5427 end Check_Arg_Is_Identifier
;
5429 ----------------------------------
5430 -- Check_Arg_Is_Integer_Literal --
5431 ----------------------------------
5433 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5434 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5436 if Nkind
(Argx
) /= N_Integer_Literal
then
5438 ("argument for pragma% must be integer literal", Argx
);
5440 end Check_Arg_Is_Integer_Literal
;
5442 -------------------------------------------
5443 -- Check_Arg_Is_Library_Level_Local_Name --
5444 -------------------------------------------
5448 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5449 -- | library_unit_NAME
5451 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5453 Check_Arg_Is_Local_Name
(Arg
);
5455 -- If it came from an aspect, we want to give the error just as if it
5456 -- came from source.
5458 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5459 and then (Comes_From_Source
(N
)
5460 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5463 ("argument for pragma% must be library level entity", Arg
);
5465 end Check_Arg_Is_Library_Level_Local_Name
;
5467 -----------------------------
5468 -- Check_Arg_Is_Local_Name --
5469 -----------------------------
5473 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5474 -- | library_unit_NAME
5476 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5477 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5480 -- If this pragma came from an aspect specification, we don't want to
5481 -- check for this error, because that would cause spurious errors, in
5482 -- case a type is frozen in a scope more nested than the type. The
5483 -- aspect itself of course can't be anywhere but on the declaration
5486 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5487 if From_Aspect_Specification
(Parent
(Arg
)) then
5491 -- Arg is the Expression of an N_Pragma_Argument_Association
5494 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5501 if Nkind
(Argx
) not in N_Direct_Name
5502 and then (Nkind
(Argx
) /= N_Attribute_Reference
5503 or else Present
(Expressions
(Argx
))
5504 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5505 and then (not Is_Entity_Name
(Argx
)
5506 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5508 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5511 -- No further check required if not an entity name
5513 if not Is_Entity_Name
(Argx
) then
5519 Ent
: constant Entity_Id
:= Entity
(Argx
);
5520 Scop
: constant Entity_Id
:= Scope
(Ent
);
5523 -- Case of a pragma applied to a compilation unit: pragma must
5524 -- occur immediately after the program unit in the compilation.
5526 if Is_Compilation_Unit
(Ent
) then
5528 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5531 -- Case of pragma placed immediately after spec
5533 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5536 -- Case of pragma placed immediately after body
5538 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5539 and then Present
(Corresponding_Body
(Decl
))
5543 (Parent
(Unit_Declaration_Node
5544 (Corresponding_Body
(Decl
))));
5546 -- All other cases are illegal
5553 -- Special restricted placement rule from 10.2.1(11.8/2)
5555 elsif Is_Generic_Formal
(Ent
)
5556 and then Prag_Id
= Pragma_Preelaborable_Initialization
5558 OK
:= List_Containing
(N
) =
5559 Generic_Formal_Declarations
5560 (Unit_Declaration_Node
(Scop
));
5562 -- If this is an aspect applied to a subprogram body, the
5563 -- pragma is inserted in its declarative part.
5565 elsif From_Aspect_Specification
(N
)
5566 and then Ent
= Current_Scope
5568 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5572 -- If the aspect is a predicate (possibly others ???) and the
5573 -- context is a record type, this is a discriminant expression
5574 -- within a type declaration, that freezes the predicated
5577 elsif From_Aspect_Specification
(N
)
5578 and then Prag_Id
= Pragma_Predicate
5579 and then Ekind
(Current_Scope
) = E_Record_Type
5580 and then Scop
= Scope
(Current_Scope
)
5584 -- Default case, just check that the pragma occurs in the scope
5585 -- of the entity denoted by the name.
5588 OK
:= Current_Scope
= Scop
;
5593 ("pragma% argument must be in same declarative part", Arg
);
5597 end Check_Arg_Is_Local_Name
;
5599 ---------------------------------
5600 -- Check_Arg_Is_Locking_Policy --
5601 ---------------------------------
5603 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5604 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5607 Check_Arg_Is_Identifier
(Argx
);
5609 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5610 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5612 end Check_Arg_Is_Locking_Policy
;
5614 -----------------------------------------------
5615 -- Check_Arg_Is_Partition_Elaboration_Policy --
5616 -----------------------------------------------
5618 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5619 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5622 Check_Arg_Is_Identifier
(Argx
);
5624 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5626 ("& is not a valid partition elaboration policy name", Argx
);
5628 end Check_Arg_Is_Partition_Elaboration_Policy
;
5630 -------------------------
5631 -- Check_Arg_Is_One_Of --
5632 -------------------------
5634 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5635 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5638 Check_Arg_Is_Identifier
(Argx
);
5640 if Chars
(Argx
) not in N1 | N2
then
5641 Error_Msg_Name_2
:= N1
;
5642 Error_Msg_Name_3
:= N2
;
5643 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5645 end Check_Arg_Is_One_Of
;
5647 procedure Check_Arg_Is_One_Of
5649 N1
, N2
, N3
: Name_Id
)
5651 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5654 Check_Arg_Is_Identifier
(Argx
);
5656 if Chars
(Argx
) not in N1 | N2 | N3
then
5657 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5659 end Check_Arg_Is_One_Of
;
5661 procedure Check_Arg_Is_One_Of
5663 N1
, N2
, N3
, N4
: Name_Id
)
5665 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5668 Check_Arg_Is_Identifier
(Argx
);
5670 if Chars
(Argx
) not in N1 | N2 | N3 | N4
then
5671 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5673 end Check_Arg_Is_One_Of
;
5675 procedure Check_Arg_Is_One_Of
5677 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5679 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5682 Check_Arg_Is_Identifier
(Argx
);
5684 if Chars
(Argx
) not in N1 | N2 | N3 | N4 | N5
then
5685 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5687 end Check_Arg_Is_One_Of
;
5689 ---------------------------------
5690 -- Check_Arg_Is_Queuing_Policy --
5691 ---------------------------------
5693 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5694 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5697 Check_Arg_Is_Identifier
(Argx
);
5699 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5700 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5702 end Check_Arg_Is_Queuing_Policy
;
5704 ---------------------------------------
5705 -- Check_Arg_Is_OK_Static_Expression --
5706 ---------------------------------------
5708 procedure Check_Arg_Is_OK_Static_Expression
5710 Typ
: Entity_Id
:= Empty
)
5713 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5714 end Check_Arg_Is_OK_Static_Expression
;
5716 ------------------------------------------
5717 -- Check_Arg_Is_Task_Dispatching_Policy --
5718 ------------------------------------------
5720 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5721 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5724 Check_Arg_Is_Identifier
(Argx
);
5726 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5728 ("& is not an allowed task dispatching policy name", Argx
);
5730 end Check_Arg_Is_Task_Dispatching_Policy
;
5732 ---------------------
5733 -- Check_Arg_Order --
5734 ---------------------
5736 procedure Check_Arg_Order
(Names
: Name_List
) is
5739 Highest_So_Far
: Natural := 0;
5740 -- Highest index in Names seen do far
5744 for J
in 1 .. Arg_Count
loop
5745 if Chars
(Arg
) /= No_Name
then
5746 for K
in Names
'Range loop
5747 if Chars
(Arg
) = Names
(K
) then
5748 if K
< Highest_So_Far
then
5749 Error_Msg_Name_1
:= Pname
;
5751 ("parameters out of order for pragma%", Arg
);
5752 Error_Msg_Name_1
:= Names
(K
);
5753 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5754 Error_Msg_N
("\% must appear before %", Arg
);
5758 Highest_So_Far
:= K
;
5766 end Check_Arg_Order
;
5768 --------------------------------
5769 -- Check_At_Least_N_Arguments --
5770 --------------------------------
5772 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5774 if Arg_Count
< N
then
5775 Error_Pragma
("too few arguments for pragma%");
5777 end Check_At_Least_N_Arguments
;
5779 -------------------------------
5780 -- Check_At_Most_N_Arguments --
5781 -------------------------------
5783 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5786 if Arg_Count
> N
then
5788 for J
in 1 .. N
loop
5790 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5793 end Check_At_Most_N_Arguments
;
5795 ---------------------
5796 -- Check_Component --
5797 ---------------------
5799 procedure Check_Component
5802 In_Variant_Part
: Boolean := False)
5804 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5805 Sindic
: constant Node_Id
:=
5806 Subtype_Indication
(Component_Definition
(Comp
));
5807 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5810 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5811 -- object constraint, then the component type shall be an Unchecked_
5814 if Nkind
(Sindic
) = N_Subtype_Indication
5815 and then Has_Per_Object_Constraint
(Comp_Id
)
5816 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5819 ("component subtype subject to per-object constraint "
5820 & "must be an Unchecked_Union", Comp
);
5822 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5823 -- the body of a generic unit, or within the body of any of its
5824 -- descendant library units, no part of the type of a component
5825 -- declared in a variant_part of the unchecked union type shall be of
5826 -- a formal private type or formal private extension declared within
5827 -- the formal part of the generic unit.
5829 elsif Ada_Version
>= Ada_2012
5830 and then In_Generic_Body
(UU_Typ
)
5831 and then In_Variant_Part
5832 and then Is_Private_Type
(Typ
)
5833 and then Is_Generic_Type
(Typ
)
5836 ("component of unchecked union cannot be of generic type", Comp
);
5838 elsif Needs_Finalization
(Typ
) then
5840 ("component of unchecked union cannot be controlled", Comp
);
5842 elsif Has_Task
(Typ
) then
5844 ("component of unchecked union cannot have tasks", Comp
);
5846 end Check_Component
;
5848 ----------------------------
5849 -- Check_Duplicate_Pragma --
5850 ----------------------------
5852 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5853 Id
: Entity_Id
:= E
;
5857 -- Nothing to do if this pragma comes from an aspect specification,
5858 -- since we could not be duplicating a pragma, and we dealt with the
5859 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5861 if From_Aspect_Specification
(N
) then
5865 -- Otherwise current pragma may duplicate previous pragma or a
5866 -- previously given aspect specification or attribute definition
5867 -- clause for the same pragma.
5869 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5873 -- If the entity is a type, then we have to make sure that the
5874 -- ostensible duplicate is not for a parent type from which this
5878 if Nkind
(P
) = N_Pragma
then
5880 Args
: constant List_Id
:=
5881 Pragma_Argument_Associations
(P
);
5884 and then Is_Entity_Name
(Expression
(First
(Args
)))
5885 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5886 and then Entity
(Expression
(First
(Args
))) /= E
5892 elsif Nkind
(P
) = N_Aspect_Specification
5893 and then Is_Type
(Entity
(P
))
5894 and then Entity
(P
) /= E
5900 -- Here we have a definite duplicate
5902 Error_Msg_Name_1
:= Pragma_Name
(N
);
5903 Error_Msg_Sloc
:= Sloc
(P
);
5905 -- For a single protected or a single task object, the error is
5906 -- issued on the original entity.
5908 if Ekind
(Id
) in E_Task_Type | E_Protected_Type
then
5909 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5912 if Nkind
(P
) = N_Aspect_Specification
5913 or else From_Aspect_Specification
(P
)
5915 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5917 -- If -gnatwr is set, warn in case of a duplicate pragma
5918 -- [No_]Inline which is suspicious but not an error, generate
5919 -- an error for other pragmas.
5921 if Pragma_Name
(N
) in Name_Inline | Name_No_Inline
then
5922 if Warn_On_Redundant_Constructs
then
5924 ("?r?pragma% for & duplicates pragma#", N
, Id
);
5927 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5933 end Check_Duplicate_Pragma
;
5935 ----------------------------------
5936 -- Check_Duplicated_Export_Name --
5937 ----------------------------------
5939 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5940 String_Val
: constant String_Id
:= Strval
(Nam
);
5943 -- We are only interested in the export case, and in the case of
5944 -- generics, it is the instance, not the template, that is the
5945 -- problem (the template will generate a warning in any case).
5947 if not Inside_A_Generic
5948 and then (Prag_Id
= Pragma_Export
5950 Prag_Id
= Pragma_Export_Procedure
5952 Prag_Id
= Pragma_Export_Valued_Procedure
5954 Prag_Id
= Pragma_Export_Function
)
5956 for J
in Externals
.First
.. Externals
.Last
loop
5957 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5958 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5959 Error_Msg_N
("external name duplicates name given#", Nam
);
5964 Externals
.Append
(Nam
);
5966 end Check_Duplicated_Export_Name
;
5968 ----------------------------------------
5969 -- Check_Expr_Is_OK_Static_Expression --
5970 ----------------------------------------
5972 procedure Check_Expr_Is_OK_Static_Expression
5974 Typ
: Entity_Id
:= Empty
)
5977 if Present
(Typ
) then
5978 Analyze_And_Resolve
(Expr
, Typ
);
5980 Analyze_And_Resolve
(Expr
);
5983 -- An expression cannot be considered static if its resolution failed
5984 -- or if it's erroneous. Stop the analysis of the related pragma.
5986 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5989 elsif Is_OK_Static_Expression
(Expr
) then
5992 -- An interesting special case, if we have a string literal and we
5993 -- are in Ada 83 mode, then we allow it even though it will not be
5994 -- flagged as static. This allows the use of Ada 95 pragmas like
5995 -- Import in Ada 83 mode. They will of course be flagged with
5996 -- warnings as usual, but will not cause errors.
5998 elsif Ada_Version
= Ada_83
5999 and then Nkind
(Expr
) = N_String_Literal
6003 -- Finally, we have a real error
6006 Error_Msg_Name_1
:= Pname
;
6007 Flag_Non_Static_Expr
6008 (Fix_Error
("argument for pragma% must be a static expression!"),
6012 end Check_Expr_Is_OK_Static_Expression
;
6014 -------------------------
6015 -- Check_First_Subtype --
6016 -------------------------
6018 procedure Check_First_Subtype
(Arg
: Node_Id
) is
6019 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6020 Ent
: constant Entity_Id
:= Entity
(Argx
);
6023 if Is_First_Subtype
(Ent
) then
6026 elsif Is_Type
(Ent
) then
6028 ("pragma% cannot apply to subtype", Argx
);
6030 elsif Is_Object
(Ent
) then
6032 ("pragma% cannot apply to object, requires a type", Argx
);
6036 ("pragma% cannot apply to&, requires a type", Argx
);
6038 end Check_First_Subtype
;
6040 ----------------------
6041 -- Check_Identifier --
6042 ----------------------
6044 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6047 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6049 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
6050 Error_Msg_Name_1
:= Pname
;
6051 Error_Msg_Name_2
:= Id
;
6052 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6056 end Check_Identifier
;
6058 --------------------------------
6059 -- Check_Identifier_Is_One_Of --
6060 --------------------------------
6062 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
6065 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6067 if Chars
(Arg
) = No_Name
then
6068 Error_Msg_Name_1
:= Pname
;
6069 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
6072 elsif Chars
(Arg
) /= N1
6073 and then Chars
(Arg
) /= N2
6075 Error_Msg_Name_1
:= Pname
;
6076 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
6080 end Check_Identifier_Is_One_Of
;
6082 ---------------------------
6083 -- Check_In_Main_Program --
6084 ---------------------------
6086 procedure Check_In_Main_Program
is
6087 P
: constant Node_Id
:= Parent
(N
);
6090 -- Must be in subprogram body
6092 if Nkind
(P
) /= N_Subprogram_Body
then
6093 Error_Pragma
("% pragma allowed only in subprogram");
6095 -- Otherwise warn if obviously not main program
6097 elsif Present
(Parameter_Specifications
(Specification
(P
)))
6098 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
6100 Error_Msg_Name_1
:= Pname
;
6102 ("??pragma% is only effective in main program", N
);
6104 end Check_In_Main_Program
;
6106 ---------------------------------------
6107 -- Check_Interrupt_Or_Attach_Handler --
6108 ---------------------------------------
6110 procedure Check_Interrupt_Or_Attach_Handler
is
6111 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6112 Handler_Proc
, Proc_Scope
: Entity_Id
;
6117 if Prag_Id
= Pragma_Interrupt_Handler
then
6118 Check_Restriction
(No_Dynamic_Attachment
, N
);
6121 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
6122 Proc_Scope
:= Scope
(Handler_Proc
);
6124 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
6126 ("argument of pragma% must be protected procedure", Arg1
);
6129 -- For pragma case (as opposed to access case), check placement.
6130 -- We don't need to do that for aspects, because we have the
6131 -- check that they aspect applies an appropriate procedure.
6133 if not From_Aspect_Specification
(N
)
6134 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
6136 Error_Pragma
("pragma% must be in protected definition");
6139 if not Is_Library_Level_Entity
(Proc_Scope
) then
6141 ("argument for pragma% must be library level entity", Arg1
);
6144 -- AI05-0033: A pragma cannot appear within a generic body, because
6145 -- instance can be in a nested scope. The check that protected type
6146 -- is itself a library-level declaration is done elsewhere.
6148 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
6149 -- handle code prior to AI-0033. Analysis tools typically are not
6150 -- interested in this pragma in any case, so no need to worry too
6151 -- much about its placement.
6153 if Inside_A_Generic
then
6154 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
6155 and then In_Package_Body
(Scope
(Current_Scope
))
6156 and then not Relaxed_RM_Semantics
6158 Error_Pragma
("pragma% cannot be used inside a generic");
6161 end Check_Interrupt_Or_Attach_Handler
;
6163 ---------------------------------
6164 -- Check_Loop_Pragma_Placement --
6165 ---------------------------------
6167 procedure Check_Loop_Pragma_Placement
is
6168 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
6169 -- Verify whether the current pragma is properly grouped with other
6170 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
6171 -- related loop where the pragma appears.
6173 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
6174 -- Determine whether an arbitrary statement Stmt denotes pragma
6175 -- Loop_Invariant or Loop_Variant.
6177 procedure Placement_Error
(Constr
: Node_Id
);
6178 pragma No_Return
(Placement_Error
);
6179 -- Node Constr denotes the last loop restricted construct before we
6180 -- encountered an illegal relation between enclosing constructs. Emit
6181 -- an error depending on what Constr was.
6183 --------------------------------
6184 -- Check_Loop_Pragma_Grouping --
6185 --------------------------------
6187 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6188 Stop_Search
: exception;
6189 -- This exception is used to terminate the recursive descent of
6190 -- routine Check_Grouping.
6192 procedure Check_Grouping
(L
: List_Id
);
6193 -- Find the first group of pragmas in list L and if successful,
6194 -- ensure that the current pragma is part of that group. The
6195 -- routine raises Stop_Search once such a check is performed to
6196 -- halt the recursive descent.
6198 procedure Grouping_Error
(Prag
: Node_Id
);
6199 pragma No_Return
(Grouping_Error
);
6200 -- Emit an error concerning the current pragma indicating that it
6201 -- should be placed after pragma Prag.
6203 --------------------
6204 -- Check_Grouping --
6205 --------------------
6207 procedure Check_Grouping
(L
: List_Id
) is
6210 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6213 -- Inspect the list of declarations or statements looking for
6214 -- the first grouping of pragmas:
6217 -- pragma Loop_Invariant ...;
6218 -- pragma Loop_Variant ...;
6220 -- pragma Loop_Variant ...; -- current pragma
6222 -- If the current pragma is not in the grouping, then it must
6223 -- either appear in a different declarative or statement list
6224 -- or the construct at (1) is separating the pragma from the
6228 while Present
(Stmt
) loop
6230 -- First pragma of the first topmost grouping has been found
6232 if Is_Loop_Pragma
(Stmt
) then
6234 -- The group and the current pragma are not in the same
6235 -- declarative or statement list.
6237 if not In_Same_List
(Stmt
, N
) then
6238 Grouping_Error
(Stmt
);
6240 -- Try to reach the current pragma from the first pragma
6241 -- of the grouping while skipping other members:
6243 -- pragma Loop_Invariant ...; -- first pragma
6244 -- pragma Loop_Variant ...; -- member
6246 -- pragma Loop_Variant ...; -- current pragma
6249 while Present
(Stmt
) loop
6250 -- The current pragma is either the first pragma
6251 -- of the group or is a member of the group.
6252 -- Stop the search as the placement is legal.
6257 -- Skip group members, but keep track of the
6258 -- last pragma in the group.
6260 elsif Is_Loop_Pragma
(Stmt
) then
6263 -- Skip declarations and statements generated by
6264 -- the compiler during expansion. Note that some
6265 -- source statements (e.g. pragma Assert) may have
6266 -- been transformed so that they do not appear as
6267 -- coming from source anymore, so we instead look
6268 -- at their Original_Node.
6270 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6274 -- A non-pragma is separating the group from the
6275 -- current pragma, the placement is illegal.
6278 Grouping_Error
(Prag
);
6284 -- If the traversal did not reach the current pragma,
6285 -- then the list must be malformed.
6287 raise Program_Error
;
6290 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6291 -- inside a loop or a block housed inside a loop. Inspect
6292 -- the declarations and statements of the block as they may
6293 -- contain the first grouping. This case follows the one for
6294 -- loop pragmas, as block statements which originate in a
6295 -- loop pragma (and so Is_Loop_Pragma will return True on
6296 -- that block statement) should be treated in the previous
6299 elsif Nkind
(Stmt
) = N_Block_Statement
then
6300 HSS
:= Handled_Statement_Sequence
(Stmt
);
6302 Check_Grouping
(Declarations
(Stmt
));
6304 if Present
(HSS
) then
6305 Check_Grouping
(Statements
(HSS
));
6313 --------------------
6314 -- Grouping_Error --
6315 --------------------
6317 procedure Grouping_Error
(Prag
: Node_Id
) is
6319 Error_Msg_Sloc
:= Sloc
(Prag
);
6320 Error_Pragma
("pragma% must appear next to pragma#");
6323 -- Start of processing for Check_Loop_Pragma_Grouping
6326 -- Inspect the statements of the loop or nested blocks housed
6327 -- within to determine whether the current pragma is part of the
6328 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6330 Check_Grouping
(Statements
(Loop_Stmt
));
6333 when Stop_Search
=> null;
6334 end Check_Loop_Pragma_Grouping
;
6336 --------------------
6337 -- Is_Loop_Pragma --
6338 --------------------
6340 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6341 Original_Stmt
: constant Node_Id
:= Original_Node
(Stmt
);
6344 -- Inspect the original node as Loop_Invariant and Loop_Variant
6345 -- pragmas are rewritten to null when assertions are disabled.
6347 return Nkind
(Original_Stmt
) = N_Pragma
6348 and then Pragma_Name_Unmapped
(Original_Stmt
)
6349 in Name_Loop_Invariant | Name_Loop_Variant
;
6352 ---------------------
6353 -- Placement_Error --
6354 ---------------------
6356 procedure Placement_Error
(Constr
: Node_Id
) is
6357 LA
: constant String := " with Loop_Entry";
6360 if Prag_Id
= Pragma_Assert
then
6361 Error_Msg_String
(1 .. LA
'Length) := LA
;
6362 Error_Msg_Strlen
:= LA
'Length;
6364 Error_Msg_Strlen
:= 0;
6367 if Nkind
(Constr
) = N_Pragma
then
6369 ("pragma %~ must appear immediately within the statements "
6373 ("block containing pragma %~ must appear immediately within "
6374 & "the statements of a loop", Constr
);
6376 end Placement_Error
;
6378 -- Local declarations
6383 -- Start of processing for Check_Loop_Pragma_Placement
6386 -- Check that pragma appears immediately within a loop statement,
6387 -- ignoring intervening block statements.
6391 while Present
(Stmt
) loop
6393 -- The pragma or previous block must appear immediately within the
6394 -- current block's declarative or statement part.
6396 if Nkind
(Stmt
) = N_Block_Statement
then
6397 if (No
(Declarations
(Stmt
))
6398 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6400 List_Containing
(Prev
) /=
6401 Statements
(Handled_Statement_Sequence
(Stmt
))
6403 Placement_Error
(Prev
);
6406 -- Keep inspecting the parents because we are now within a
6407 -- chain of nested blocks.
6411 Stmt
:= Parent
(Stmt
);
6414 -- The pragma or previous block must appear immediately within the
6415 -- statements of the loop.
6417 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6418 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6419 Placement_Error
(Prev
);
6422 -- Stop the traversal because we reached the innermost loop
6423 -- regardless of whether we encountered an error or not.
6427 -- Ignore a handled statement sequence. Note that this node may
6428 -- be related to a subprogram body in which case we will emit an
6429 -- error on the next iteration of the search.
6431 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6432 Stmt
:= Parent
(Stmt
);
6434 -- Any other statement breaks the chain from the pragma to the
6438 Placement_Error
(Prev
);
6443 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6444 -- grouped together with other such pragmas.
6446 if Is_Loop_Pragma
(N
) then
6448 -- The previous check should have located the related loop
6450 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6451 Check_Loop_Pragma_Grouping
(Stmt
);
6453 end Check_Loop_Pragma_Placement
;
6455 -------------------------------------------
6456 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6457 -------------------------------------------
6459 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6468 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6471 elsif Nkind
(P
) in N_Package_Specification | N_Block_Statement
then
6474 -- Note: the following tests seem a little peculiar, because
6475 -- they test for bodies, but if we were in the statement part
6476 -- of the body, we would already have hit the handled statement
6477 -- sequence, so the only way we get here is by being in the
6478 -- declarative part of the body.
6481 N_Subprogram_Body | N_Package_Body | N_Task_Body | N_Entry_Body
6489 Error_Pragma
("pragma% is not in declarative part or package spec");
6490 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6492 -------------------------
6493 -- Check_No_Identifier --
6494 -------------------------
6496 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6498 if Nkind
(Arg
) = N_Pragma_Argument_Association
6499 and then Chars
(Arg
) /= No_Name
6501 Error_Pragma_Arg_Ident
6502 ("pragma% does not permit identifier& here", Arg
);
6504 end Check_No_Identifier
;
6506 --------------------------
6507 -- Check_No_Identifiers --
6508 --------------------------
6510 procedure Check_No_Identifiers
is
6514 for J
in 1 .. Arg_Count
loop
6515 Check_No_Identifier
(Arg_Node
);
6518 end Check_No_Identifiers
;
6520 ------------------------
6521 -- Check_No_Link_Name --
6522 ------------------------
6524 procedure Check_No_Link_Name
is
6526 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6530 if Present
(Arg4
) then
6532 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6534 end Check_No_Link_Name
;
6536 -------------------------------
6537 -- Check_Optional_Identifier --
6538 -------------------------------
6540 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6543 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6544 and then Chars
(Arg
) /= No_Name
6546 if Chars
(Arg
) /= Id
then
6547 Error_Msg_Name_1
:= Pname
;
6548 Error_Msg_Name_2
:= Id
;
6549 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6553 end Check_Optional_Identifier
;
6555 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6557 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6558 end Check_Optional_Identifier
;
6560 -------------------------------------
6561 -- Check_Static_Boolean_Expression --
6562 -------------------------------------
6564 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6566 if Present
(Expr
) then
6567 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6569 if not Is_OK_Static_Expression
(Expr
) then
6571 ("expression of pragma % must be static", Expr
);
6574 end Check_Static_Boolean_Expression
;
6576 -----------------------------
6577 -- Check_Static_Constraint --
6578 -----------------------------
6580 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6582 procedure Require_Static
(E
: Node_Id
);
6583 -- Require given expression to be static expression
6585 --------------------
6586 -- Require_Static --
6587 --------------------
6589 procedure Require_Static
(E
: Node_Id
) is
6591 if not Is_OK_Static_Expression
(E
) then
6592 Flag_Non_Static_Expr
6593 ("non-static constraint not allowed in Unchecked_Union!", E
);
6598 -- Start of processing for Check_Static_Constraint
6601 case Nkind
(Constr
) is
6602 when N_Discriminant_Association
=>
6603 Require_Static
(Expression
(Constr
));
6606 Require_Static
(Low_Bound
(Constr
));
6607 Require_Static
(High_Bound
(Constr
));
6609 when N_Attribute_Reference
=>
6610 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6611 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6613 when N_Range_Constraint
=>
6614 Check_Static_Constraint
(Range_Expression
(Constr
));
6616 when N_Index_Or_Discriminant_Constraint
=>
6620 IDC
:= First
(Constraints
(Constr
));
6621 while Present
(IDC
) loop
6622 Check_Static_Constraint
(IDC
);
6630 end Check_Static_Constraint
;
6632 --------------------------------------
6633 -- Check_Valid_Configuration_Pragma --
6634 --------------------------------------
6636 -- A configuration pragma must appear in the context clause of a
6637 -- compilation unit, and only other pragmas may precede it. Note that
6638 -- the test also allows use in a configuration pragma file.
6640 procedure Check_Valid_Configuration_Pragma
is
6642 if not Is_Configuration_Pragma
then
6643 Error_Pragma
("incorrect placement for configuration pragma%");
6645 end Check_Valid_Configuration_Pragma
;
6647 -------------------------------------
6648 -- Check_Valid_Library_Unit_Pragma --
6649 -------------------------------------
6651 procedure Check_Valid_Library_Unit_Pragma
is
6653 Parent_Node
: Node_Id
;
6654 Unit_Name
: Entity_Id
;
6655 Unit_Kind
: Node_Kind
;
6656 Unit_Node
: Node_Id
;
6657 Sindex
: Source_File_Index
;
6660 if not Is_List_Member
(N
) then
6664 Plist
:= List_Containing
(N
);
6665 Parent_Node
:= Parent
(Plist
);
6667 if Parent_Node
= Empty
then
6670 -- Case of pragma appearing after a compilation unit. In this case
6671 -- it must have an argument with the corresponding name and must
6672 -- be part of the following pragmas of its parent.
6674 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6675 if Plist
/= Pragmas_After
(Parent_Node
) then
6677 ("pragma% misplaced, must be inside or after the "
6678 & "compilation unit");
6680 elsif Arg_Count
= 0 then
6682 ("argument required if outside compilation unit");
6685 Check_No_Identifiers
;
6686 Check_Arg_Count
(1);
6687 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6688 Unit_Kind
:= Nkind
(Unit_Node
);
6690 Analyze
(Get_Pragma_Arg
(Arg1
));
6692 if Unit_Kind
= N_Generic_Subprogram_Declaration
6693 or else Unit_Kind
= N_Subprogram_Declaration
6695 Unit_Name
:= Defining_Entity
(Unit_Node
);
6697 elsif Unit_Kind
in N_Generic_Instantiation
then
6698 Unit_Name
:= Defining_Entity
(Unit_Node
);
6701 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6704 if Chars
(Unit_Name
) /=
6705 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6708 ("pragma% argument is not current unit name", Arg1
);
6711 if Ekind
(Unit_Name
) = E_Package
6712 and then Present
(Renamed_Entity
(Unit_Name
))
6714 Error_Pragma
("pragma% not allowed for renamed package");
6718 -- Pragma appears other than after a compilation unit
6721 -- Here we check for the generic instantiation case and also
6722 -- for the case of processing a generic formal package. We
6723 -- detect these cases by noting that the Sloc on the node
6724 -- does not belong to the current compilation unit.
6726 Sindex
:= Source_Index
(Current_Sem_Unit
);
6728 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6729 -- We do not want to raise an exception here since this code
6730 -- is part of the bootstrap path where we cannot rely on
6731 -- exception proapgation working.
6732 -- Instead the caller should check for N being rewritten as
6733 -- a null statement.
6734 -- This code triggers when compiling a-except.adb.
6736 Rewrite
(N
, Make_Null_Statement
(Loc
));
6738 -- If before first declaration, the pragma applies to the
6739 -- enclosing unit, and the name if present must be this name.
6741 elsif Is_Before_First_Decl
(N
, Plist
) then
6742 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6743 Unit_Kind
:= Nkind
(Unit_Node
);
6745 if Unit_Node
= Standard_Package_Node
then
6747 ("pragma% misplaced, must be inside or after the "
6748 & "compilation unit");
6750 elsif Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6752 ("pragma% misplaced, must be on library unit");
6754 elsif Unit_Kind
= N_Subprogram_Body
6755 and then not Acts_As_Spec
(Unit_Node
)
6758 ("pragma% misplaced, must be on the subprogram spec");
6760 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6762 ("pragma% misplaced, must be on the package spec");
6764 elsif Nkind
(Parent_Node
) = N_Package_Specification
6765 and then Plist
= Private_Declarations
(Parent_Node
)
6768 ("pragma% misplaced, must be in the public part");
6770 elsif Nkind
(Parent_Node
) in N_Generic_Declaration
6771 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6774 ("pragma% misplaced, must not be in formal part");
6776 elsif Arg_Count
> 0 then
6777 Analyze
(Get_Pragma_Arg
(Arg1
));
6779 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6781 ("name in pragma% must be enclosing unit", Arg1
);
6784 -- It is legal to have no argument in this context
6790 -- Error if not before first declaration. This is because a
6791 -- library unit pragma argument must be the name of a library
6792 -- unit (RM 10.1.5(7)), but the only names permitted in this
6793 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6794 -- generic subprogram declarations or generic instantiations.
6798 ("pragma% misplaced, must be before first declaration");
6802 end Check_Valid_Library_Unit_Pragma
;
6808 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6809 Clist
: constant Node_Id
:= Component_List
(Variant
);
6813 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6814 while Present
(Comp
) loop
6815 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6816 Next_Non_Pragma
(Comp
);
6820 ---------------------------
6821 -- Ensure_Aggregate_Form --
6822 ---------------------------
6824 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6825 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6826 Expr
: constant Node_Id
:= Expression
(Arg
);
6827 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6828 Comps
: List_Id
:= No_List
;
6829 Exprs
: List_Id
:= No_List
;
6830 Nam
: Name_Id
:= No_Name
;
6831 Nam_Loc
: Source_Ptr
;
6834 -- The pragma argument is in positional form:
6836 -- pragma Depends (Nam => ...)
6840 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6841 -- argument association.
6843 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6845 Nam_Loc
:= Sloc
(Arg
);
6847 -- Remove the pragma argument name as this will be captured in the
6850 Set_Chars
(Arg
, No_Name
);
6853 -- The argument is already in aggregate form, but the presence of a
6854 -- name causes this to be interpreted as named association which in
6855 -- turn must be converted into an aggregate.
6857 -- pragma Global (In_Out => (A, B, C))
6861 -- pragma Global ((In_Out => (A, B, C)))
6863 -- aggregate aggregate
6865 if Nkind
(Expr
) = N_Aggregate
then
6866 if Nam
= No_Name
then
6870 -- Do not transform a null argument into an aggregate as N_Null has
6871 -- special meaning in formal verification pragmas.
6873 elsif Nkind
(Expr
) = N_Null
then
6877 -- Everything comes from source if the original comes from source
6879 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6881 -- Positional argument is transformed into an aggregate with an
6882 -- Expressions list.
6884 if Nam
= No_Name
then
6885 Exprs
:= New_List
(Relocate_Node
(Expr
));
6887 -- An associative argument is transformed into an aggregate with
6888 -- Component_Associations.
6892 Make_Component_Association
(Loc
,
6893 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6894 Expression
=> Relocate_Node
(Expr
)));
6897 Set_Expression
(Arg
,
6898 Make_Aggregate
(Loc
,
6899 Component_Associations
=> Comps
,
6900 Expressions
=> Exprs
));
6902 -- Restore Comes_From_Source default
6904 Set_Comes_From_Source_Default
(CFSD
);
6905 end Ensure_Aggregate_Form
;
6911 procedure Error_Pragma
(Msg
: String) is
6913 Error_Msg_Name_1
:= Pname
;
6914 Error_Msg_N
(Fix_Error
(Msg
), N
);
6918 ----------------------
6919 -- Error_Pragma_Arg --
6920 ----------------------
6922 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6924 Error_Msg_Name_1
:= Pname
;
6925 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6927 end Error_Pragma_Arg
;
6929 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6931 Error_Msg_Name_1
:= Pname
;
6932 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6933 Error_Pragma_Arg
(Msg2
, Arg
);
6934 end Error_Pragma_Arg
;
6936 ----------------------------
6937 -- Error_Pragma_Arg_Ident --
6938 ----------------------------
6940 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6942 Error_Msg_Name_1
:= Pname
;
6943 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6945 end Error_Pragma_Arg_Ident
;
6947 ----------------------
6948 -- Error_Pragma_Ref --
6949 ----------------------
6951 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6953 Error_Msg_Name_1
:= Pname
;
6954 Error_Msg_Sloc
:= Sloc
(Ref
);
6955 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6957 end Error_Pragma_Ref
;
6959 ------------------------
6960 -- Find_Lib_Unit_Name --
6961 ------------------------
6963 function Find_Lib_Unit_Name
return Entity_Id
is
6965 -- Return inner compilation unit entity, for case of nested
6966 -- categorization pragmas. This happens in generic unit.
6968 if Nkind
(Parent
(N
)) = N_Package_Specification
6969 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6971 return Defining_Entity
(Parent
(N
));
6973 return Current_Scope
;
6975 end Find_Lib_Unit_Name
;
6977 ----------------------------
6978 -- Find_Program_Unit_Name --
6979 ----------------------------
6981 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6982 Unit_Name
: Entity_Id
;
6983 Unit_Kind
: Node_Kind
;
6984 P
: constant Node_Id
:= Parent
(N
);
6987 if Nkind
(P
) = N_Compilation_Unit
then
6988 Unit_Kind
:= Nkind
(Unit
(P
));
6990 if Unit_Kind
in N_Subprogram_Declaration
6991 | N_Package_Declaration
6992 | N_Generic_Declaration
6994 Unit_Name
:= Defining_Entity
(Unit
(P
));
6996 if Chars
(Id
) = Chars
(Unit_Name
) then
6997 Set_Entity
(Id
, Unit_Name
);
6998 Set_Etype
(Id
, Etype
(Unit_Name
));
7000 Set_Etype
(Id
, Any_Type
);
7002 ("cannot find program unit referenced by pragma%");
7006 Set_Etype
(Id
, Any_Type
);
7007 Error_Pragma
("pragma% inapplicable to this unit");
7013 end Find_Program_Unit_Name
;
7015 -----------------------------------------
7016 -- Find_Unique_Parameterless_Procedure --
7017 -----------------------------------------
7019 function Find_Unique_Parameterless_Procedure
7021 Arg
: Node_Id
) return Entity_Id
7023 Proc
: Entity_Id
:= Empty
;
7026 -- Perform sanity checks on Name
7028 if not Is_Entity_Name
(Name
) then
7030 ("argument of pragma% must be entity name", Arg
);
7032 elsif not Is_Overloaded
(Name
) then
7033 Proc
:= Entity
(Name
);
7035 if Ekind
(Proc
) /= E_Procedure
7036 or else Present
(First_Formal
(Proc
))
7039 ("argument of pragma% must be parameterless procedure", Arg
);
7042 -- Otherwise, search through interpretations looking for one which
7043 -- has no parameters.
7047 Found
: Boolean := False;
7049 Index
: Interp_Index
;
7052 Get_First_Interp
(Name
, Index
, It
);
7053 while Present
(It
.Nam
) loop
7056 if Ekind
(Proc
) = E_Procedure
7057 and then No
(First_Formal
(Proc
))
7059 -- We found an interpretation, note it and continue
7060 -- looking looking to verify it is unique.
7064 Set_Entity
(Name
, Proc
);
7065 Set_Is_Overloaded
(Name
, False);
7067 -- Two procedures with the same name, log an error
7068 -- since the name is ambiguous.
7072 ("ambiguous handler name for pragma%", Arg
);
7076 Get_Next_Interp
(Index
, It
);
7080 -- Issue an error if we haven't found a suitable match for
7084 ("argument of pragma% must be parameterless procedure",
7088 Proc
:= Entity
(Name
);
7094 end Find_Unique_Parameterless_Procedure
;
7100 function Fix_Error
(Msg
: String) return String is
7101 Res
: String (Msg
'Range) := Msg
;
7102 Res_Last
: Natural := Msg
'Last;
7106 -- If we have a rewriting of another pragma, go to that pragma
7108 if Is_Rewrite_Substitution
(N
)
7109 and then Nkind
(Original_Node
(N
)) = N_Pragma
7111 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
7114 -- Case where pragma comes from an aspect specification
7116 if From_Aspect_Specification
(N
) then
7118 -- Change appearence of "pragma" in message to "aspect"
7121 while J
<= Res_Last
- 5 loop
7122 if Res
(J
.. J
+ 5) = "pragma" then
7123 Res
(J
.. J
+ 5) := "aspect";
7131 -- Change "argument of" at start of message to "entity for"
7134 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
7136 Res
(Res
'First .. Res
'First + 9) := "entity for";
7137 Res
(Res
'First + 10 .. Res_Last
- 1) :=
7138 Res
(Res
'First + 11 .. Res_Last
);
7139 Res_Last
:= Res_Last
- 1;
7142 -- Change "argument" at start of message to "entity"
7145 and then Res
(Res
'First .. Res
'First + 7) = "argument"
7147 Res
(Res
'First .. Res
'First + 5) := "entity";
7148 Res
(Res
'First + 6 .. Res_Last
- 2) :=
7149 Res
(Res
'First + 8 .. Res_Last
);
7150 Res_Last
:= Res_Last
- 2;
7153 -- Get name from corresponding aspect
7155 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
7158 -- Return possibly modified message
7160 return Res
(Res
'First .. Res_Last
);
7163 -------------------------
7164 -- Gather_Associations --
7165 -------------------------
7167 procedure Gather_Associations
7169 Args
: out Args_List
)
7174 -- Initialize all parameters to Empty
7176 for J
in Args
'Range loop
7180 -- That's all we have to do if there are no argument associations
7182 if No
(Pragma_Argument_Associations
(N
)) then
7186 -- Otherwise first deal with any positional parameters present
7188 Arg
:= First
(Pragma_Argument_Associations
(N
));
7189 for Index
in Args
'Range loop
7190 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
7191 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7195 -- Positional parameters all processed, if any left, then we
7196 -- have too many positional parameters.
7198 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
7200 ("too many positional associations for pragma%", Arg
);
7203 -- Process named parameters if any are present
7205 while Present
(Arg
) loop
7206 if Chars
(Arg
) = No_Name
then
7208 ("positional association cannot follow named association",
7212 for Index
in Names
'Range loop
7213 if Names
(Index
) = Chars
(Arg
) then
7214 if Present
(Args
(Index
)) then
7216 ("duplicate argument association for pragma%", Arg
);
7218 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7223 if Index
= Names
'Last then
7224 Error_Msg_Name_1
:= Pname
;
7225 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7227 -- Check for possible misspelling
7229 for Index1
in Names
'Range loop
7230 if Is_Bad_Spelling_Of
7231 (Chars
(Arg
), Names
(Index1
))
7233 Error_Msg_Name_1
:= Names
(Index1
);
7234 Error_Msg_N
-- CODEFIX
7235 ("\possible misspelling of%", Arg
);
7247 end Gather_Associations
;
7253 procedure GNAT_Pragma
is
7255 -- We need to check the No_Implementation_Pragmas restriction for
7256 -- the case of a pragma from source. Note that the case of aspects
7257 -- generating corresponding pragmas marks these pragmas as not being
7258 -- from source, so this test also catches that case.
7260 if Comes_From_Source
(N
) then
7261 Check_Restriction
(No_Implementation_Pragmas
, N
);
7265 --------------------------
7266 -- Is_Before_First_Decl --
7267 --------------------------
7269 function Is_Before_First_Decl
7270 (Pragma_Node
: Node_Id
;
7271 Decls
: List_Id
) return Boolean
7273 Item
: Node_Id
:= First
(Decls
);
7276 -- Only other pragmas can come before this pragma, but they might
7277 -- have been rewritten so check the original node.
7280 if No
(Item
) or else Nkind
(Original_Node
(Item
)) /= N_Pragma
then
7283 elsif Item
= Pragma_Node
then
7289 end Is_Before_First_Decl
;
7291 -----------------------------
7292 -- Is_Configuration_Pragma --
7293 -----------------------------
7295 -- A configuration pragma must appear in the context clause of a
7296 -- compilation unit, and only other pragmas may precede it. Note that
7297 -- the test below also permits use in a configuration pragma file.
7299 function Is_Configuration_Pragma
return Boolean is
7300 Lis
: constant List_Id
:= List_Containing
(N
);
7301 Par
: constant Node_Id
:= Parent
(N
);
7305 -- If no parent, then we are in the configuration pragma file,
7306 -- so the placement is definitely appropriate.
7311 -- Otherwise we must be in the context clause of a compilation unit
7312 -- and the only thing allowed before us in the context list is more
7313 -- configuration pragmas.
7315 elsif Nkind
(Par
) = N_Compilation_Unit
7316 and then Context_Items
(Par
) = Lis
7323 elsif Nkind
(Prg
) /= N_Pragma
then
7333 end Is_Configuration_Pragma
;
7335 --------------------------
7336 -- Is_In_Context_Clause --
7337 --------------------------
7339 function Is_In_Context_Clause
return Boolean is
7341 Parent_Node
: Node_Id
;
7344 if not Is_List_Member
(N
) then
7348 Plist
:= List_Containing
(N
);
7349 Parent_Node
:= Parent
(Plist
);
7351 if Parent_Node
= Empty
7352 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7353 or else Context_Items
(Parent_Node
) /= Plist
7360 end Is_In_Context_Clause
;
7362 ---------------------------------
7363 -- Is_Static_String_Expression --
7364 ---------------------------------
7366 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7367 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7368 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7371 Analyze_And_Resolve
(Argx
);
7373 -- Special case Ada 83, where the expression will never be static,
7374 -- but we will return true if we had a string literal to start with.
7376 if Ada_Version
= Ada_83
then
7379 -- Normal case, true only if we end up with a string literal that
7380 -- is marked as being the result of evaluating a static expression.
7383 return Is_OK_Static_Expression
(Argx
)
7384 and then Nkind
(Argx
) = N_String_Literal
;
7387 end Is_Static_String_Expression
;
7389 ----------------------
7390 -- Pragma_Misplaced --
7391 ----------------------
7393 procedure Pragma_Misplaced
is
7395 Error_Pragma
("incorrect placement of pragma%");
7396 end Pragma_Misplaced
;
7398 ------------------------------------------------
7399 -- Process_Atomic_Independent_Shared_Volatile --
7400 ------------------------------------------------
7402 procedure Process_Atomic_Independent_Shared_Volatile
is
7403 procedure Check_Full_Access_Only
(Ent
: Entity_Id
);
7404 -- Apply legality checks to type or object Ent subject to the
7405 -- Full_Access_Only aspect in Ada 2022 (RM C.6(8.2)).
7407 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7408 -- Appropriately set flags on the given entity, either an array or
7409 -- record component, or an object declaration) according to the
7412 procedure Mark_Type
(Ent
: Entity_Id
);
7413 -- Appropriately set flags on the given entity, a type
7415 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7416 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7417 -- no explicit alignment was given, set alignment to unknown, since
7418 -- back end knows what the alignment requirements are for atomic and
7419 -- full access arrays. Note: this is necessary for derived types.
7421 -------------------------
7422 -- Check_Full_Access_Only --
7423 -------------------------
7425 procedure Check_Full_Access_Only
(Ent
: Entity_Id
) is
7428 Full_Access_Subcomponent
: exception;
7429 -- Exception raised if a full access subcomponent is found
7431 Generic_Type_Subcomponent
: exception;
7432 -- Exception raised if a subcomponent with generic type is found
7434 procedure Check_Subcomponents
(Typ
: Entity_Id
);
7435 -- Apply checks to subcomponents recursively
7437 -------------------------
7438 -- Check_Subcomponents --
7439 -------------------------
7441 procedure Check_Subcomponents
(Typ
: Entity_Id
) is
7445 if Is_Array_Type
(Typ
) then
7446 Comp
:= Component_Type
(Typ
);
7448 if Has_Atomic_Components
(Typ
)
7449 or else Is_Full_Access
(Comp
)
7451 raise Full_Access_Subcomponent
;
7453 elsif Is_Generic_Type
(Comp
) then
7454 raise Generic_Type_Subcomponent
;
7457 -- Recurse on the component type
7459 Check_Subcomponents
(Comp
);
7461 elsif Is_Record_Type
(Typ
) then
7462 Comp
:= First_Component_Or_Discriminant
(Typ
);
7463 while Present
(Comp
) loop
7465 if Is_Full_Access
(Comp
)
7466 or else Is_Full_Access
(Etype
(Comp
))
7468 raise Full_Access_Subcomponent
;
7470 elsif Is_Generic_Type
(Etype
(Comp
)) then
7471 raise Generic_Type_Subcomponent
;
7474 -- Recurse on the component type
7476 Check_Subcomponents
(Etype
(Comp
));
7478 Next_Component_Or_Discriminant
(Comp
);
7481 end Check_Subcomponents
;
7483 -- Start of processing for Check_Full_Access_Only
7486 -- Fetch the type in case we are dealing with an object or
7489 if Is_Type
(Ent
) then
7492 pragma Assert
(Is_Object
(Ent
)
7494 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7499 if not Is_Volatile
(Ent
) and then not Is_Volatile
(Typ
) then
7501 ("cannot have Full_Access_Only without Volatile/Atomic "
7506 -- Check all the subcomponents of the type recursively, if any
7508 Check_Subcomponents
(Typ
);
7511 when Full_Access_Subcomponent
=>
7513 ("cannot have Full_Access_Only with full access subcomponent "
7516 when Generic_Type_Subcomponent
=>
7518 ("cannot have Full_Access_Only with subcomponent of generic "
7519 & "type (RM C.6(8.2))");
7521 end Check_Full_Access_Only
;
7523 ------------------------------
7524 -- Mark_Component_Or_Object --
7525 ------------------------------
7527 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7529 if Prag_Id
= Pragma_Atomic
7530 or else Prag_Id
= Pragma_Shared
7531 or else Prag_Id
= Pragma_Volatile_Full_Access
7533 if Prag_Id
= Pragma_Volatile_Full_Access
then
7534 Set_Is_Volatile_Full_Access
(Ent
);
7536 Set_Is_Atomic
(Ent
);
7539 -- If the object declaration has an explicit initialization, a
7540 -- temporary may have to be created to hold the expression, to
7541 -- ensure that access to the object remains atomic.
7543 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7544 and then Present
(Expression
(Parent
(Ent
)))
7546 Set_Has_Delayed_Freeze
(Ent
);
7550 -- Atomic/Shared/Volatile_Full_Access imply Independent
7552 if Prag_Id
/= Pragma_Volatile
then
7553 Set_Is_Independent
(Ent
);
7555 if Prag_Id
= Pragma_Independent
then
7556 Record_Independence_Check
(N
, Ent
);
7560 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7562 if Prag_Id
/= Pragma_Independent
then
7563 Set_Is_Volatile
(Ent
);
7564 Set_Treat_As_Volatile
(Ent
);
7566 end Mark_Component_Or_Object
;
7572 procedure Mark_Type
(Ent
: Entity_Id
) is
7574 -- Attribute belongs on the base type. If the view of the type is
7575 -- currently private, it also belongs on the underlying type.
7577 -- In Ada 2022, the pragma can apply to a formal type, for which
7578 -- there may be no underlying type.
7580 if Prag_Id
= Pragma_Atomic
7581 or else Prag_Id
= Pragma_Shared
7582 or else Prag_Id
= Pragma_Volatile_Full_Access
7584 Set_Atomic_VFA
(Ent
);
7585 Set_Atomic_VFA
(Base_Type
(Ent
));
7587 if not Is_Generic_Type
(Ent
) then
7588 Set_Atomic_VFA
(Underlying_Type
(Ent
));
7592 -- Atomic/Shared/Volatile_Full_Access imply Independent
7594 if Prag_Id
/= Pragma_Volatile
then
7595 Set_Is_Independent
(Ent
);
7596 Set_Is_Independent
(Base_Type
(Ent
));
7598 if not Is_Generic_Type
(Ent
) then
7599 Set_Is_Independent
(Underlying_Type
(Ent
));
7601 if Prag_Id
= Pragma_Independent
then
7602 Record_Independence_Check
(N
, Base_Type
(Ent
));
7607 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7609 if Prag_Id
/= Pragma_Independent
then
7610 Set_Is_Volatile
(Ent
);
7611 Set_Is_Volatile
(Base_Type
(Ent
));
7613 if not Is_Generic_Type
(Ent
) then
7614 Set_Is_Volatile
(Underlying_Type
(Ent
));
7615 Set_Treat_As_Volatile
(Underlying_Type
(Ent
));
7618 Set_Treat_As_Volatile
(Ent
);
7621 -- Apply Volatile to the composite type's individual components,
7624 if Prag_Id
= Pragma_Volatile
7625 and then Is_Record_Type
(Etype
(Ent
))
7630 Comp
:= First_Component
(Ent
);
7631 while Present
(Comp
) loop
7632 Mark_Component_Or_Object
(Comp
);
7634 Next_Component
(Comp
);
7640 --------------------
7641 -- Set_Atomic_VFA --
7642 --------------------
7644 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7646 if Prag_Id
= Pragma_Volatile_Full_Access
then
7647 Set_Is_Volatile_Full_Access
(Ent
);
7649 Set_Is_Atomic
(Ent
);
7652 if not Has_Alignment_Clause
(Ent
) then
7653 Reinit_Alignment
(Ent
);
7663 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7666 Check_Ada_83_Warning
;
7667 Check_No_Identifiers
;
7668 Check_Arg_Count
(1);
7669 Check_Arg_Is_Local_Name
(Arg1
);
7670 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7672 if Etype
(E_Arg
) = Any_Type
then
7676 E
:= Entity
(E_Arg
);
7677 Decl
:= Declaration_Node
(E
);
7679 -- A pragma that applies to a Ghost entity becomes Ghost for the
7680 -- purposes of legality checks and removal of ignored Ghost code.
7682 Mark_Ghost_Pragma
(N
, E
);
7684 -- Check duplicate before we chain ourselves
7686 Check_Duplicate_Pragma
(E
);
7688 -- Check the constraints of Full_Access_Only in Ada 2022. Note that
7689 -- they do not apply to GNAT's Volatile_Full_Access because 1) this
7690 -- aspect subsumes the Volatile aspect and 2) nesting is supported
7691 -- for this aspect and the outermost enclosing VFA object prevails.
7693 -- Note also that we used to forbid specifying both Atomic and VFA on
7694 -- the same type or object, but the restriction has been lifted in
7695 -- light of the semantics of Full_Access_Only and Atomic in Ada 2022.
7697 if Prag_Id
= Pragma_Volatile_Full_Access
7698 and then From_Aspect_Specification
(N
)
7700 Get_Aspect_Id
(Corresponding_Aspect
(N
)) = Aspect_Full_Access_Only
7702 Check_Full_Access_Only
(E
);
7705 -- The following check is only relevant when SPARK_Mode is on as
7706 -- this is not a standard Ada legality rule. Pragma Volatile can
7707 -- only apply to a full type declaration or an object declaration
7708 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7709 -- untagged derived types that are rewritten as subtypes of their
7710 -- respective root types.
7713 and then Prag_Id
= Pragma_Volatile
7714 and then Nkind
(Original_Node
(Decl
)) not in
7715 N_Full_Type_Declaration |
7716 N_Formal_Type_Declaration |
7717 N_Object_Declaration |
7718 N_Single_Protected_Declaration |
7719 N_Single_Task_Declaration
7722 ("argument of pragma % must denote a full type or object "
7723 & "declaration", Arg1
);
7726 -- Deal with the case where the pragma/attribute is applied to a type
7729 if Rep_Item_Too_Early
(E
, N
)
7730 or else Rep_Item_Too_Late
(E
, N
)
7734 Check_First_Subtype
(Arg1
);
7739 -- Deal with the case where the pragma/attribute applies to a
7740 -- component or object declaration.
7742 elsif Nkind
(Decl
) = N_Object_Declaration
7743 or else (Nkind
(Decl
) = N_Component_Declaration
7744 and then Original_Record_Component
(E
) = E
)
7746 if Rep_Item_Too_Late
(E
, N
) then
7750 Mark_Component_Or_Object
(E
);
7752 -- In other cases give an error
7755 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7757 end Process_Atomic_Independent_Shared_Volatile
;
7759 -------------------------------------------
7760 -- Process_Compile_Time_Warning_Or_Error --
7761 -------------------------------------------
7763 procedure Process_Compile_Time_Warning_Or_Error
is
7764 P
: Node_Id
:= Parent
(N
);
7765 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7768 Check_Arg_Count
(2);
7769 Check_No_Identifiers
;
7770 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7771 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7773 -- In GNATprove mode, pragma Compile_Time_Error is translated as
7774 -- a Check pragma in GNATprove mode, handled as an assumption in
7775 -- GNATprove. This is correct as the compiler will issue an error
7776 -- if the condition cannot be statically evaluated to False.
7777 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7778 -- same information as the compiler (in particular regarding size of
7779 -- objects decided in gigi) so it makes no sense to issue a warning
7782 if GNATprove_Mode
then
7783 if Prag_Id
= Pragma_Compile_Time_Error
then
7787 -- Implement Compile_Time_Error by generating
7788 -- a corresponding Check pragma:
7790 -- pragma Check (name, condition);
7792 -- where name is the identifier matching the pragma name. So
7793 -- rewrite pragma in this manner and analyze the result.
7795 New_Args
:= New_List
7796 (Make_Pragma_Argument_Association
7798 Expression
=> Make_Identifier
(Loc
, Pname
)),
7799 Make_Pragma_Argument_Association
7801 Expression
=> Arg1x
));
7803 -- Rewrite as Check pragma
7807 Chars
=> Name_Check
,
7808 Pragma_Argument_Associations
=> New_Args
));
7814 Rewrite
(N
, Make_Null_Statement
(Loc
));
7820 -- If the condition is known at compile time (now), validate it now.
7821 -- Otherwise, register the expression for validation after the back
7822 -- end has been called, because it might be known at compile time
7823 -- then. For example, if the expression is "Record_Type'Size /= 32"
7824 -- it might be known after the back end has determined the size of
7825 -- Record_Type. We do not defer validation if we're inside a generic
7826 -- unit, because we will have more information in the instances.
7828 if Compile_Time_Known_Value
(Arg1x
) then
7829 Validate_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7832 while Present
(P
) and then Nkind
(P
) not in N_Generic_Declaration
7834 if (Nkind
(P
) = N_Subprogram_Body
and then not Acts_As_Spec
(P
))
7835 or else Nkind
(P
) = N_Package_Body
7837 P
:= Parent
(Corresponding_Spec
(P
));
7845 Defer_Compile_Time_Warning_Error_To_BE
(N
);
7848 end Process_Compile_Time_Warning_Or_Error
;
7850 ------------------------
7851 -- Process_Convention --
7852 ------------------------
7854 procedure Process_Convention
7855 (C
: out Convention_Id
;
7856 Ent
: out Entity_Id
)
7860 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7861 -- Called if we have more than one Export/Import/Convention pragma.
7862 -- This is generally illegal, but we have a special case of allowing
7863 -- Import and Interface to coexist if they specify the convention in
7864 -- a consistent manner. We are allowed to do this, since Interface is
7865 -- an implementation defined pragma, and we choose to do it since we
7866 -- know Rational allows this combination. S is the entity id of the
7867 -- subprogram in question. This procedure also sets the special flag
7868 -- Import_Interface_Present in both pragmas in the case where we do
7869 -- have matching Import and Interface pragmas.
7871 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7872 -- Set convention in entity E, and also flag that the entity has a
7873 -- convention pragma. If entity is for a private or incomplete type,
7874 -- also set convention and flag on underlying type. This procedure
7875 -- also deals with the special case of C_Pass_By_Copy convention,
7876 -- and error checks for inappropriate convention specification.
7878 -------------------------------
7879 -- Diagnose_Multiple_Pragmas --
7880 -------------------------------
7882 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7883 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7887 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7888 -- Decl is a pragma node. This function returns True if this
7889 -- pragma has a first argument that is an identifier with a
7890 -- Chars field corresponding to the Convention_Id C.
7892 function Same_Name
(Decl
: Node_Id
) return Boolean;
7893 -- Decl is a pragma node. This function returns True if this
7894 -- pragma has a second argument that is an identifier with a
7895 -- Chars field that matches the Chars of the current subprogram.
7897 ---------------------
7898 -- Same_Convention --
7899 ---------------------
7901 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7902 Arg1
: constant Node_Id
:=
7903 First
(Pragma_Argument_Associations
(Decl
));
7906 if Present
(Arg1
) then
7908 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7910 if Nkind
(Arg
) = N_Identifier
7911 and then Is_Convention_Name
(Chars
(Arg
))
7912 and then Get_Convention_Id
(Chars
(Arg
)) = C
7920 end Same_Convention
;
7926 function Same_Name
(Decl
: Node_Id
) return Boolean is
7927 Arg1
: constant Node_Id
:=
7928 First
(Pragma_Argument_Associations
(Decl
));
7936 Arg2
:= Next
(Arg1
);
7943 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7945 if Nkind
(Arg
) = N_Identifier
7946 and then Chars
(Arg
) = Chars
(S
)
7955 -- Start of processing for Diagnose_Multiple_Pragmas
7960 -- Definitely give message if we have Convention/Export here
7962 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7965 -- If we have an Import or Export, scan back from pragma to
7966 -- find any previous pragma applying to the same procedure.
7967 -- The scan will be terminated by the start of the list, or
7968 -- hitting the subprogram declaration. This won't allow one
7969 -- pragma to appear in the public part and one in the private
7970 -- part, but that seems very unlikely in practice.
7974 while Present
(Decl
) and then Decl
/= Pdec
loop
7976 -- Look for pragma with same name as us
7978 if Nkind
(Decl
) = N_Pragma
7979 and then Same_Name
(Decl
)
7981 -- Give error if same as our pragma or Export/Convention
7983 if Pragma_Name_Unmapped
(Decl
)
7986 | Pragma_Name_Unmapped
(N
)
7990 -- Case of Import/Interface or the other way round
7992 elsif Pragma_Name_Unmapped
(Decl
)
7993 in Name_Interface | Name_Import
7995 -- Here we know that we have Import and Interface. It
7996 -- doesn't matter which way round they are. See if
7997 -- they specify the same convention. If so, all OK,
7998 -- and set special flags to stop other messages
8000 if Same_Convention
(Decl
) then
8001 Set_Import_Interface_Present
(N
);
8002 Set_Import_Interface_Present
(Decl
);
8005 -- If different conventions, special message
8008 Error_Msg_Sloc
:= Sloc
(Decl
);
8010 ("convention differs from that given#", Arg1
);
8020 -- Give message if needed if we fall through those tests
8021 -- except on Relaxed_RM_Semantics where we let go: either this
8022 -- is a case accepted/ignored by other Ada compilers (e.g.
8023 -- a mix of Convention and Import), or another error will be
8024 -- generated later (e.g. using both Import and Export).
8026 if Err
and not Relaxed_RM_Semantics
then
8028 ("at most one Convention/Export/Import pragma is allowed",
8031 end Diagnose_Multiple_Pragmas
;
8033 --------------------------------
8034 -- Set_Convention_From_Pragma --
8035 --------------------------------
8037 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
8039 -- Ada 2005 (AI-430): Check invalid attempt to change convention
8040 -- for an overridden dispatching operation. Technically this is
8041 -- an amendment and should only be done in Ada 2005 mode. However,
8042 -- this is clearly a mistake, since the problem that is addressed
8043 -- by this AI is that there is a clear gap in the RM.
8045 if Is_Dispatching_Operation
(E
)
8046 and then Present
(Overridden_Operation
(E
))
8047 and then C
/= Convention
(Overridden_Operation
(E
))
8050 ("cannot change convention for overridden dispatching "
8051 & "operation", Arg1
);
8053 -- Special check for convention Stdcall: a dispatching call is not
8054 -- allowed. A dispatching subprogram cannot be used to interface
8055 -- to the Win32 API, so this check actually does not impose any
8056 -- effective restriction.
8058 elsif Is_Dispatching_Operation
(E
)
8059 and then C
= Convention_Stdcall
8061 -- Note: make this unconditional so that if there is more
8062 -- than one call to which the pragma applies, we get a
8063 -- message for each call. Also don't use Error_Pragma,
8064 -- so that we get multiple messages.
8066 Error_Msg_Sloc
:= Sloc
(E
);
8068 ("dispatching subprogram# cannot use Stdcall convention!",
8069 Get_Pragma_Arg
(Arg1
));
8072 -- Set the convention
8074 Set_Convention
(E
, C
);
8075 Set_Has_Convention_Pragma
(E
);
8077 -- For the case of a record base type, also set the convention of
8078 -- any anonymous access types declared in the record which do not
8079 -- currently have a specified convention.
8080 -- Similarly for an array base type and anonymous access types
8083 if Is_Base_Type
(E
) then
8084 if Is_Record_Type
(E
) then
8089 Comp
:= First_Component
(E
);
8090 while Present
(Comp
) loop
8091 if Present
(Etype
(Comp
))
8093 Ekind
(Etype
(Comp
)) in
8094 E_Anonymous_Access_Type |
8095 E_Anonymous_Access_Subprogram_Type
8096 and then not Has_Convention_Pragma
(Comp
)
8098 Set_Convention
(Comp
, C
);
8101 Next_Component
(Comp
);
8105 elsif Is_Array_Type
(E
)
8106 and then Ekind
(Component_Type
(E
)) in
8107 E_Anonymous_Access_Type |
8108 E_Anonymous_Access_Subprogram_Type
8110 Set_Convention
(Designated_Type
(Component_Type
(E
)), C
);
8114 -- Deal with incomplete/private type case, where underlying type
8115 -- is available, so set convention of that underlying type.
8117 if Is_Incomplete_Or_Private_Type
(E
)
8118 and then Present
(Underlying_Type
(E
))
8120 Set_Convention
(Underlying_Type
(E
), C
);
8121 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
8124 -- A class-wide type should inherit the convention of the specific
8125 -- root type (although this isn't specified clearly by the RM).
8127 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
8128 Set_Convention
(Class_Wide_Type
(E
), C
);
8131 -- If the entity is a record type, then check for special case of
8132 -- C_Pass_By_Copy, which is treated the same as C except that the
8133 -- special record flag is set. This convention is only permitted
8134 -- on record types (see AI95-00131).
8136 if Cname
= Name_C_Pass_By_Copy
then
8137 if Is_Record_Type
(E
) then
8138 Set_C_Pass_By_Copy
(Base_Type
(E
));
8139 elsif Is_Incomplete_Or_Private_Type
(E
)
8140 and then Is_Record_Type
(Underlying_Type
(E
))
8142 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
8145 ("C_Pass_By_Copy convention allowed only for record type",
8150 -- If the entity is a derived boolean type, check for the special
8151 -- case of convention C, C++, or Fortran, where we consider any
8152 -- nonzero value to represent true.
8154 if Is_Discrete_Type
(E
)
8155 and then Root_Type
(Etype
(E
)) = Standard_Boolean
8161 C
= Convention_Fortran
)
8163 Set_Nonzero_Is_True
(Base_Type
(E
));
8165 end Set_Convention_From_Pragma
;
8169 Comp_Unit
: Unit_Number_Type
;
8175 -- Start of processing for Process_Convention
8178 Check_At_Least_N_Arguments
(2);
8179 Check_Optional_Identifier
(Arg1
, Name_Convention
);
8180 Check_Arg_Is_Identifier
(Arg1
);
8181 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
8183 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
8184 -- tested again below to set the critical flag).
8186 if Cname
= Name_C_Pass_By_Copy
then
8189 -- Otherwise we must have something in the standard convention list
8191 elsif Is_Convention_Name
(Cname
) then
8192 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
8194 -- Otherwise warn on unrecognized convention
8197 if Warn_On_Export_Import
then
8199 ("??unrecognized convention name, C assumed",
8200 Get_Pragma_Arg
(Arg1
));
8206 Check_Optional_Identifier
(Arg2
, Name_Entity
);
8207 Check_Arg_Is_Local_Name
(Arg2
);
8209 Id
:= Get_Pragma_Arg
(Arg2
);
8212 if not Is_Entity_Name
(Id
) then
8213 Error_Pragma_Arg
("entity name required", Arg2
);
8218 -- Set entity to return
8222 -- Ada_Pass_By_Copy special checking
8224 if C
= Convention_Ada_Pass_By_Copy
then
8225 if not Is_First_Subtype
(E
) then
8227 ("convention `Ada_Pass_By_Copy` only allowed for types",
8231 if Is_By_Reference_Type
(E
) then
8233 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8237 -- Ada_Pass_By_Reference special checking
8239 elsif C
= Convention_Ada_Pass_By_Reference
then
8240 if not Is_First_Subtype
(E
) then
8242 ("convention `Ada_Pass_By_Reference` only allowed for types",
8246 if Is_By_Copy_Type
(E
) then
8248 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8253 -- Go to renamed subprogram if present, since convention applies to
8254 -- the actual renamed entity, not to the renaming entity. If the
8255 -- subprogram is inherited, go to parent subprogram.
8257 if Is_Subprogram
(E
)
8258 and then Present
(Alias
(E
))
8260 if Nkind
(Parent
(Declaration_Node
(E
))) =
8261 N_Subprogram_Renaming_Declaration
8263 if Scope
(E
) /= Scope
(Alias
(E
)) then
8265 ("cannot apply pragma% to non-local entity&#", E
);
8270 elsif Nkind
(Parent
(E
)) in
8271 N_Full_Type_Declaration | N_Private_Extension_Declaration
8272 and then Scope
(E
) = Scope
(Alias
(E
))
8276 -- Return the parent subprogram the entity was inherited from
8282 -- Check that we are not applying this to a specless body. Relax this
8283 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8285 if Is_Subprogram
(E
)
8286 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8287 and then not Relaxed_RM_Semantics
8290 ("pragma% requires separate spec and must come before body");
8293 -- Check that we are not applying this to a named constant
8295 if Is_Named_Number
(E
) then
8296 Error_Msg_Name_1
:= Pname
;
8298 ("cannot apply pragma% to named constant!",
8299 Get_Pragma_Arg
(Arg2
));
8301 ("\supply appropriate type for&!", Arg2
);
8304 if Ekind
(E
) = E_Enumeration_Literal
then
8305 Error_Pragma
("enumeration literal not allowed for pragma%");
8308 -- Check for rep item appearing too early or too late
8310 if Etype
(E
) = Any_Type
8311 or else Rep_Item_Too_Early
(E
, N
)
8315 elsif Present
(Underlying_Type
(E
)) then
8316 E
:= Underlying_Type
(E
);
8319 if Rep_Item_Too_Late
(E
, N
) then
8323 if Has_Convention_Pragma
(E
) then
8324 Diagnose_Multiple_Pragmas
(E
);
8326 elsif Convention
(E
) = Convention_Protected
8327 or else Ekind
(Scope
(E
)) = E_Protected_Type
8330 ("a protected operation cannot be given a different convention",
8334 -- For Intrinsic, a subprogram is required
8336 if C
= Convention_Intrinsic
8337 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8339 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8341 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8342 if From_Aspect_Specification
(N
) then
8344 ("entity for aspect% must be a subprogram", Arg2
);
8347 ("second argument of pragma% must be a subprogram", Arg2
);
8351 -- Special checks for C_Variadic_n
8353 elsif C
in Convention_C_Variadic
then
8355 -- Several allowed cases
8357 if Is_Subprogram_Or_Generic_Subprogram
(E
) then
8360 -- An access to subprogram is also allowed
8362 elsif Is_Access_Type
(E
)
8363 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
8365 Subp
:= Designated_Type
(E
);
8367 -- Allow internal call to set convention of subprogram type
8369 elsif Ekind
(E
) = E_Subprogram_Type
then
8374 ("argument of pragma% must be subprogram or access type",
8379 -- ISO C requires a named parameter before the ellipsis, so a
8380 -- variadic C function taking 0 fixed parameter cannot exist.
8382 if C
= Convention_C_Variadic_0
then
8385 ("??C_Variadic_0 cannot be used for an 'I'S'O C function",
8386 Get_Pragma_Arg
(Arg2
));
8388 -- Now check the number of parameters of the subprogram and give
8389 -- an error if it is lower than n.
8391 elsif Present
(Subp
) then
8393 Minimum
: constant Nat
:=
8394 Convention_Id
'Pos (C
) -
8395 Convention_Id
'Pos (Convention_C_Variadic_0
);
8402 Formal
:= First_Formal
(Subp
);
8403 while Present
(Formal
) loop
8405 Next_Formal
(Formal
);
8408 if Count
< Minimum
then
8409 Error_Msg_Uint_1
:= UI_From_Int
(Minimum
);
8411 ("argument of pragma% must have at least"
8412 & "^ parameters", Arg2
);
8417 -- Special checks for Stdcall
8419 elsif C
= Convention_Stdcall
then
8421 -- Several allowed cases
8423 if Is_Subprogram_Or_Generic_Subprogram
(E
)
8427 or else Ekind
(E
) = E_Variable
8429 -- A component as well. The entity does not have its Ekind
8430 -- set until the enclosing record declaration is fully
8433 or else Nkind
(Parent
(E
)) = N_Component_Declaration
8435 -- An access to subprogram is also allowed
8439 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
8441 -- Allow internal call to set convention of subprogram type
8443 or else Ekind
(E
) = E_Subprogram_Type
8449 ("argument of pragma% must be subprogram or access type",
8454 Set_Convention_From_Pragma
(E
);
8456 -- Deal with non-subprogram cases
8458 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8461 -- The pragma must apply to a first subtype, but it can also
8462 -- apply to a generic type in a generic formal part, in which
8463 -- case it will also appear in the corresponding instance.
8465 if Is_Generic_Type
(E
) or else In_Instance
then
8468 Check_First_Subtype
(Arg2
);
8471 Set_Convention_From_Pragma
(Base_Type
(E
));
8473 -- For access subprograms, we must set the convention on the
8474 -- internally generated directly designated type as well.
8476 if Ekind
(E
) = E_Access_Subprogram_Type
then
8477 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8481 -- For the subprogram case, set proper convention for all homonyms
8482 -- in same scope and the same declarative part, i.e. the same
8483 -- compilation unit.
8486 -- Treat a pragma Import as an implicit body, and pragma import
8487 -- as implicit reference (for navigation in GNAT Studio).
8489 if Prag_Id
= Pragma_Import
then
8490 Generate_Reference
(E
, Id
, 'b');
8492 -- For exported entities we restrict the generation of references
8493 -- to entities exported to foreign languages since entities
8494 -- exported to Ada do not provide further information to
8495 -- GNAT Studio and add undesired references to the output of the
8498 elsif Prag_Id
= Pragma_Export
8499 and then Convention
(E
) /= Convention_Ada
8501 Generate_Reference
(E
, Id
, 'i');
8504 -- If the pragma comes from an aspect, it only applies to the
8505 -- given entity, not its homonyms.
8507 if From_Aspect_Specification
(N
) then
8508 if C
= Convention_Intrinsic
8509 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8511 if Is_Fixed_Point_Type
(Etype
(Ent
))
8512 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8513 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8516 ("no intrinsic operator available for this fixed-point "
8519 ("\use expression functions with the desired "
8520 & "conversions made explicit", N
);
8527 -- Otherwise Loop through the homonyms of the pragma argument's
8528 -- entity, an apply convention to those in the current scope.
8530 Comp_Unit
:= Get_Source_Unit
(E
);
8535 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8537 -- Ignore entry for which convention is already set
8539 if Has_Convention_Pragma
(E1
) then
8543 if Is_Subprogram
(E1
)
8544 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8546 and then not Relaxed_RM_Semantics
8548 Set_Has_Completion
(E
); -- to prevent cascaded error
8550 ("pragma% requires separate spec and must come before "
8554 -- Do not set the pragma on inherited operations or on formal
8557 if Comes_From_Source
(E1
)
8558 and then Comp_Unit
= Get_Source_Unit
(E1
)
8559 and then not Is_Formal_Subprogram
(E1
)
8560 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8561 N_Full_Type_Declaration
8563 if Present
(Alias
(E1
))
8564 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8567 ("cannot apply pragma% to non-local entity& declared#",
8571 Set_Convention_From_Pragma
(E1
);
8573 if Prag_Id
= Pragma_Import
then
8574 Generate_Reference
(E1
, Id
, 'b');
8582 end Process_Convention
;
8584 ----------------------------------------
8585 -- Process_Disable_Enable_Atomic_Sync --
8586 ----------------------------------------
8588 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8590 Check_No_Identifiers
;
8591 Check_At_Most_N_Arguments
(1);
8593 -- Modeled internally as
8594 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8599 Pragma_Argument_Associations
=> New_List
(
8600 Make_Pragma_Argument_Association
(Loc
,
8602 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8604 if Present
(Arg1
) then
8605 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8609 end Process_Disable_Enable_Atomic_Sync
;
8611 -------------------------------------------------
8612 -- Process_Extended_Import_Export_Internal_Arg --
8613 -------------------------------------------------
8615 procedure Process_Extended_Import_Export_Internal_Arg
8616 (Arg_Internal
: Node_Id
:= Empty
)
8619 if No
(Arg_Internal
) then
8620 Error_Pragma
("Internal parameter required for pragma%");
8623 if Nkind
(Arg_Internal
) = N_Identifier
then
8626 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8627 and then (Prag_Id
= Pragma_Import_Function
8629 Prag_Id
= Pragma_Export_Function
)
8635 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8638 Check_Arg_Is_Local_Name
(Arg_Internal
);
8639 end Process_Extended_Import_Export_Internal_Arg
;
8641 --------------------------------------------------
8642 -- Process_Extended_Import_Export_Object_Pragma --
8643 --------------------------------------------------
8645 procedure Process_Extended_Import_Export_Object_Pragma
8646 (Arg_Internal
: Node_Id
;
8647 Arg_External
: Node_Id
;
8653 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8654 Def_Id
:= Entity
(Arg_Internal
);
8656 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
8658 ("pragma% must designate an object", Arg_Internal
);
8661 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8663 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8666 ("previous Common/Psect_Object applies, pragma % not permitted",
8670 if Rep_Item_Too_Late
(Def_Id
, N
) then
8674 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8676 if Present
(Arg_Size
) then
8677 Check_Arg_Is_External_Name
(Arg_Size
);
8680 -- Export_Object case
8682 if Prag_Id
= Pragma_Export_Object
then
8683 if not Is_Library_Level_Entity
(Def_Id
) then
8685 ("argument for pragma% must be library level entity",
8689 if Ekind
(Current_Scope
) = E_Generic_Package
then
8690 Error_Pragma
("pragma& cannot appear in a generic unit");
8693 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8695 ("exported object must have compile time known size",
8699 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8700 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8702 Set_Exported
(Def_Id
, Arg_Internal
);
8705 -- Import_Object case
8708 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8710 ("cannot use pragma% for task/protected object",
8714 if Ekind
(Def_Id
) = E_Constant
then
8716 ("cannot import a constant", Arg_Internal
);
8719 if Warn_On_Export_Import
8720 and then Has_Discriminants
(Etype
(Def_Id
))
8723 ("imported value must be initialized??", Arg_Internal
);
8726 if Warn_On_Export_Import
8727 and then Is_Access_Type
(Etype
(Def_Id
))
8730 ("cannot import object of an access type??", Arg_Internal
);
8733 if Warn_On_Export_Import
8734 and then Is_Imported
(Def_Id
)
8736 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8738 -- Check for explicit initialization present. Note that an
8739 -- initialization generated by the code generator, e.g. for an
8740 -- access type, does not count here.
8742 elsif Present
(Expression
(Parent
(Def_Id
)))
8745 (Original_Node
(Expression
(Parent
(Def_Id
))))
8747 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8749 ("imported entities cannot be initialized (RM B.1(24))",
8750 "\no initialization allowed for & declared#", Arg1
);
8752 Set_Imported
(Def_Id
);
8753 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8756 end Process_Extended_Import_Export_Object_Pragma
;
8758 ------------------------------------------------------
8759 -- Process_Extended_Import_Export_Subprogram_Pragma --
8760 ------------------------------------------------------
8762 procedure Process_Extended_Import_Export_Subprogram_Pragma
8763 (Arg_Internal
: Node_Id
;
8764 Arg_External
: Node_Id
;
8765 Arg_Parameter_Types
: Node_Id
;
8766 Arg_Result_Type
: Node_Id
:= Empty
;
8767 Arg_Mechanism
: Node_Id
;
8768 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8774 Ambiguous
: Boolean;
8777 function Same_Base_Type
8779 Formal
: Entity_Id
) return Boolean;
8780 -- Determines if Ptype references the type of Formal. Note that only
8781 -- the base types need to match according to the spec. Ptype here is
8782 -- the argument from the pragma, which is either a type name, or an
8783 -- access attribute.
8785 --------------------
8786 -- Same_Base_Type --
8787 --------------------
8789 function Same_Base_Type
8791 Formal
: Entity_Id
) return Boolean
8793 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8797 -- Case where pragma argument is typ'Access
8799 if Nkind
(Ptype
) = N_Attribute_Reference
8800 and then Attribute_Name
(Ptype
) = Name_Access
8802 Pref
:= Prefix
(Ptype
);
8805 if not Is_Entity_Name
(Pref
)
8806 or else Entity
(Pref
) = Any_Type
8811 -- We have a match if the corresponding argument is of an
8812 -- anonymous access type, and its designated type matches the
8813 -- type of the prefix of the access attribute
8815 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8816 and then Base_Type
(Entity
(Pref
)) =
8817 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8819 -- Case where pragma argument is a type name
8824 if not Is_Entity_Name
(Ptype
)
8825 or else Entity
(Ptype
) = Any_Type
8830 -- We have a match if the corresponding argument is of the type
8831 -- given in the pragma (comparing base types)
8833 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8837 -- Start of processing for
8838 -- Process_Extended_Import_Export_Subprogram_Pragma
8841 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8845 -- Loop through homonyms (overloadings) of the entity
8847 Hom_Id
:= Entity
(Arg_Internal
);
8848 while Present
(Hom_Id
) loop
8849 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8851 -- We need a subprogram in the current scope
8853 if not Is_Subprogram
(Def_Id
)
8854 or else Scope
(Def_Id
) /= Current_Scope
8861 -- Pragma cannot apply to subprogram body
8863 if Is_Subprogram
(Def_Id
)
8864 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8868 ("pragma% requires separate spec and must come before "
8872 -- Test result type if given, note that the result type
8873 -- parameter can only be present for the function cases.
8875 if Present
(Arg_Result_Type
)
8876 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8880 elsif Etype
(Def_Id
) /= Standard_Void_Type
8882 Pname
in Name_Export_Procedure | Name_Import_Procedure
8886 -- Test parameter types if given. Note that this parameter has
8887 -- not been analyzed (and must not be, since it is semantic
8888 -- nonsense), so we get it as the parser left it.
8890 elsif Present
(Arg_Parameter_Types
) then
8891 Check_Matching_Types
: declare
8896 Formal
:= First_Formal
(Def_Id
);
8898 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8899 if Present
(Formal
) then
8903 -- A list of one type, e.g. (List) is parsed as a
8904 -- parenthesized expression.
8906 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8907 and then Paren_Count
(Arg_Parameter_Types
) = 1
8910 or else Present
(Next_Formal
(Formal
))
8915 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8918 -- A list of more than one type is parsed as a aggregate
8920 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8921 and then Paren_Count
(Arg_Parameter_Types
) = 0
8923 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8924 while Present
(Ptype
) or else Present
(Formal
) loop
8927 or else not Same_Base_Type
(Ptype
, Formal
)
8932 Next_Formal
(Formal
);
8937 -- Anything else is of the wrong form
8941 ("wrong form for Parameter_Types parameter",
8942 Arg_Parameter_Types
);
8944 end Check_Matching_Types
;
8947 -- Match is now False if the entry we found did not match
8948 -- either a supplied Parameter_Types or Result_Types argument
8954 -- Ambiguous case, the flag Ambiguous shows if we already
8955 -- detected this and output the initial messages.
8958 if not Ambiguous
then
8960 Error_Msg_Name_1
:= Pname
;
8962 ("pragma% does not uniquely identify subprogram!",
8964 Error_Msg_Sloc
:= Sloc
(Ent
);
8965 Error_Msg_N
("matching subprogram #!", N
);
8969 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8970 Error_Msg_N
("matching subprogram #!", N
);
8975 Hom_Id
:= Homonym
(Hom_Id
);
8978 -- See if we found an entry
8981 if not Ambiguous
then
8982 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8984 ("pragma% cannot be given for generic subprogram");
8987 ("pragma% does not identify local subprogram");
8994 -- Import pragmas must be for imported entities
8996 if Prag_Id
= Pragma_Import_Function
8998 Prag_Id
= Pragma_Import_Procedure
9000 Prag_Id
= Pragma_Import_Valued_Procedure
9002 if not Is_Imported
(Ent
) then
9004 ("pragma Import or Interface must precede pragma%");
9007 -- Here we have the Export case which can set the entity as exported
9009 -- But does not do so if the specified external name is null, since
9010 -- that is taken as a signal in DEC Ada 83 (with which we want to be
9011 -- compatible) to request no external name.
9013 elsif Nkind
(Arg_External
) = N_String_Literal
9014 and then String_Length
(Strval
(Arg_External
)) = 0
9018 -- In all other cases, set entity as exported
9021 Set_Exported
(Ent
, Arg_Internal
);
9024 -- Special processing for Valued_Procedure cases
9026 if Prag_Id
= Pragma_Import_Valued_Procedure
9028 Prag_Id
= Pragma_Export_Valued_Procedure
9030 Formal
:= First_Formal
(Ent
);
9033 Error_Pragma
("at least one parameter required for pragma%");
9035 elsif Ekind
(Formal
) /= E_Out_Parameter
then
9036 Error_Pragma
("first parameter must have mode OUT for pragma%");
9039 Set_Is_Valued_Procedure
(Ent
);
9043 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
9045 -- Process Result_Mechanism argument if present. We have already
9046 -- checked that this is only allowed for the function case.
9048 if Present
(Arg_Result_Mechanism
) then
9049 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
9052 -- Process Mechanism parameter if present. Note that this parameter
9053 -- is not analyzed, and must not be analyzed since it is semantic
9054 -- nonsense, so we get it in exactly as the parser left it.
9056 if Present
(Arg_Mechanism
) then
9064 -- A single mechanism association without a formal parameter
9065 -- name is parsed as a parenthesized expression. All other
9066 -- cases are parsed as aggregates, so we rewrite the single
9067 -- parameter case as an aggregate for consistency.
9069 if Nkind
(Arg_Mechanism
) /= N_Aggregate
9070 and then Paren_Count
(Arg_Mechanism
) = 1
9072 Rewrite
(Arg_Mechanism
,
9073 Make_Aggregate
(Sloc
(Arg_Mechanism
),
9074 Expressions
=> New_List
(
9075 Relocate_Node
(Arg_Mechanism
))));
9078 -- Case of only mechanism name given, applies to all formals
9080 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
9081 Formal
:= First_Formal
(Ent
);
9082 while Present
(Formal
) loop
9083 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
9084 Next_Formal
(Formal
);
9087 -- Case of list of mechanism associations given
9090 if Null_Record_Present
(Arg_Mechanism
) then
9092 ("inappropriate form for Mechanism parameter",
9096 -- Deal with positional ones first
9098 Formal
:= First_Formal
(Ent
);
9100 if Present
(Expressions
(Arg_Mechanism
)) then
9101 Mname
:= First
(Expressions
(Arg_Mechanism
));
9102 while Present
(Mname
) loop
9105 ("too many mechanism associations", Mname
);
9108 Set_Mechanism_Value
(Formal
, Mname
);
9109 Next_Formal
(Formal
);
9114 -- Deal with named entries
9116 if Present
(Component_Associations
(Arg_Mechanism
)) then
9117 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
9118 while Present
(Massoc
) loop
9119 Choice
:= First
(Choices
(Massoc
));
9121 if Nkind
(Choice
) /= N_Identifier
9122 or else Present
(Next
(Choice
))
9125 ("incorrect form for mechanism association",
9129 Formal
:= First_Formal
(Ent
);
9133 ("parameter name & not present", Choice
);
9136 if Chars
(Choice
) = Chars
(Formal
) then
9138 (Formal
, Expression
(Massoc
));
9140 -- Set entity on identifier for proper tree
9143 Set_Entity
(Choice
, Formal
);
9148 Next_Formal
(Formal
);
9157 end Process_Extended_Import_Export_Subprogram_Pragma
;
9159 --------------------------
9160 -- Process_Generic_List --
9161 --------------------------
9163 procedure Process_Generic_List
is
9168 Check_No_Identifiers
;
9169 Check_At_Least_N_Arguments
(1);
9171 -- Check all arguments are names of generic units or instances
9174 while Present
(Arg
) loop
9175 Exp
:= Get_Pragma_Arg
(Arg
);
9178 if not Is_Entity_Name
(Exp
)
9180 (not Is_Generic_Instance
(Entity
(Exp
))
9182 not Is_Generic_Unit
(Entity
(Exp
)))
9185 ("pragma% argument must be name of generic unit/instance",
9191 end Process_Generic_List
;
9193 ------------------------------------
9194 -- Process_Import_Predefined_Type --
9195 ------------------------------------
9197 procedure Process_Import_Predefined_Type
is
9198 Loc
: constant Source_Ptr
:= Sloc
(N
);
9200 Ftyp
: Node_Id
:= Empty
;
9206 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
9208 Elmt
:= First_Elmt
(Predefined_Float_Types
);
9209 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
9213 Ftyp
:= Node
(Elmt
);
9215 if Present
(Ftyp
) then
9217 -- Don't build a derived type declaration, because predefined C
9218 -- types have no declaration anywhere, so cannot really be named.
9219 -- Instead build a full type declaration, starting with an
9220 -- appropriate type definition is built
9222 if Is_Floating_Point_Type
(Ftyp
) then
9223 Def
:= Make_Floating_Point_Definition
(Loc
,
9224 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
9225 Make_Real_Range_Specification
(Loc
,
9226 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
9227 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
9229 -- Should never have a predefined type we cannot handle
9232 raise Program_Error
;
9235 -- Build and insert a Full_Type_Declaration, which will be
9236 -- analyzed as soon as this list entry has been analyzed.
9238 Decl
:= Make_Full_Type_Declaration
(Loc
,
9239 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
9240 Type_Definition
=> Def
);
9242 Insert_After
(N
, Decl
);
9243 Mark_Rewrite_Insertion
(Decl
);
9246 Error_Pragma_Arg
("no matching type found for pragma%", Arg2
);
9248 end Process_Import_Predefined_Type
;
9250 ---------------------------------
9251 -- Process_Import_Or_Interface --
9252 ---------------------------------
9254 procedure Process_Import_Or_Interface
is
9260 -- In Relaxed_RM_Semantics, support old Ada 83 style:
9261 -- pragma Import (Entity, "external name");
9263 if Relaxed_RM_Semantics
9264 and then Arg_Count
= 2
9265 and then Prag_Id
= Pragma_Import
9266 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
9269 Def_Id
:= Get_Pragma_Arg
(Arg1
);
9272 if not Is_Entity_Name
(Def_Id
) then
9273 Error_Pragma_Arg
("entity name required", Arg1
);
9276 Def_Id
:= Entity
(Def_Id
);
9277 Kill_Size_Check_Code
(Def_Id
);
9278 if Ekind
(Def_Id
) /= E_Constant
then
9279 Note_Possible_Modification
9280 (Get_Pragma_Arg
(Arg1
), Sure
=> False);
9284 Process_Convention
(C
, Def_Id
);
9286 -- A pragma that applies to a Ghost entity becomes Ghost for the
9287 -- purposes of legality checks and removal of ignored Ghost code.
9289 Mark_Ghost_Pragma
(N
, Def_Id
);
9290 Kill_Size_Check_Code
(Def_Id
);
9291 if Ekind
(Def_Id
) /= E_Constant
then
9292 Note_Possible_Modification
9293 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
9297 -- Various error checks
9299 if Ekind
(Def_Id
) in E_Variable | E_Constant
then
9301 -- We do not permit Import to apply to a renaming declaration
9303 if Present
(Renamed_Object
(Def_Id
)) then
9305 ("pragma% not allowed for object renaming", Arg2
);
9307 -- User initialization is not allowed for imported object, but
9308 -- the object declaration may contain a default initialization,
9309 -- that will be discarded. Note that an explicit initialization
9310 -- only counts if it comes from source, otherwise it is simply
9311 -- the code generator making an implicit initialization explicit.
9313 elsif Present
(Expression
(Parent
(Def_Id
)))
9314 and then Comes_From_Source
9315 (Original_Node
(Expression
(Parent
(Def_Id
))))
9317 -- Set imported flag to prevent cascaded errors
9319 Set_Is_Imported
(Def_Id
);
9321 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9323 ("no initialization allowed for declaration of& #",
9324 "\imported entities cannot be initialized (RM B.1(24))",
9328 -- If the pragma comes from an aspect specification the
9329 -- Is_Imported flag has already been set.
9331 if not From_Aspect_Specification
(N
) then
9332 Set_Imported
(Def_Id
);
9335 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9337 -- Note that we do not set Is_Public here. That's because we
9338 -- only want to set it if there is no address clause, and we
9339 -- don't know that yet, so we delay that processing till
9342 -- pragma Import completes deferred constants
9344 if Ekind
(Def_Id
) = E_Constant
then
9345 Set_Has_Completion
(Def_Id
);
9348 -- It is not possible to import a constant of an unconstrained
9349 -- array type (e.g. string) because there is no simple way to
9350 -- write a meaningful subtype for it.
9352 if Is_Array_Type
(Etype
(Def_Id
))
9353 and then not Is_Constrained
(Etype
(Def_Id
))
9356 ("imported constant& must have a constrained subtype",
9361 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9363 -- If the name is overloaded, pragma applies to all of the denoted
9364 -- entities in the same declarative part, unless the pragma comes
9365 -- from an aspect specification or was generated by the compiler
9366 -- (such as for pragma Provide_Shift_Operators).
9369 while Present
(Hom_Id
) loop
9371 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9373 -- Ignore inherited subprograms because the pragma will apply
9374 -- to the parent operation, which is the one called.
9376 if Is_Overloadable
(Def_Id
)
9377 and then Present
(Alias
(Def_Id
))
9381 -- If it is not a subprogram, it must be in an outer scope and
9382 -- pragma does not apply.
9384 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9387 -- The pragma does not apply to primitives of interfaces
9389 elsif Is_Dispatching_Operation
(Def_Id
)
9390 and then Present
(Find_Dispatching_Type
(Def_Id
))
9391 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9395 -- Verify that the homonym is in the same declarative part (not
9396 -- just the same scope). If the pragma comes from an aspect
9397 -- specification we know that it is part of the declaration.
9399 elsif (No
(Unit_Declaration_Node
(Def_Id
))
9400 or else Parent
(Unit_Declaration_Node
(Def_Id
)) /=
9402 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9403 and then not From_Aspect_Specification
(N
)
9408 -- If the pragma comes from an aspect specification the
9409 -- Is_Imported flag has already been set.
9411 if not From_Aspect_Specification
(N
) then
9412 Set_Imported
(Def_Id
);
9415 -- Reject an Import applied to an abstract subprogram
9417 if Is_Subprogram
(Def_Id
)
9418 and then Is_Abstract_Subprogram
(Def_Id
)
9420 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9422 ("cannot import abstract subprogram& declared#",
9426 -- Special processing for Convention_Intrinsic
9428 if C
= Convention_Intrinsic
then
9430 -- Link_Name argument not allowed for intrinsic
9434 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9436 -- If no external name is present, then check that this
9437 -- is a valid intrinsic subprogram. If an external name
9438 -- is present, then this is handled by the back end.
9441 Check_Intrinsic_Subprogram
9442 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9446 -- Verify that the subprogram does not have a completion
9447 -- through a renaming declaration. For other completions the
9448 -- pragma appears as a too late representation.
9451 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9455 and then Nkind
(Decl
) = N_Subprogram_Declaration
9456 and then Present
(Corresponding_Body
(Decl
))
9457 and then Nkind
(Unit_Declaration_Node
9458 (Corresponding_Body
(Decl
))) =
9459 N_Subprogram_Renaming_Declaration
9461 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9463 ("cannot import&, renaming already provided for "
9464 & "declaration #", N
, Def_Id
);
9468 -- If the pragma comes from an aspect specification, there
9469 -- must be an Import aspect specified as well. In the rare
9470 -- case where Import is set to False, the suprogram needs to
9471 -- have a local completion.
9474 Imp_Aspect
: constant Node_Id
:=
9475 Find_Aspect
(Def_Id
, Aspect_Import
);
9479 if Present
(Imp_Aspect
)
9480 and then Present
(Expression
(Imp_Aspect
))
9482 Expr
:= Expression
(Imp_Aspect
);
9483 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9485 if Is_Entity_Name
(Expr
)
9486 and then Entity
(Expr
) = Standard_True
9488 Set_Has_Completion
(Def_Id
);
9491 -- If there is no expression, the default is True, as for
9492 -- all boolean aspects. Same for the older pragma.
9495 Set_Has_Completion
(Def_Id
);
9499 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9502 if Is_Compilation_Unit
(Hom_Id
) then
9504 -- Its possible homonyms are not affected by the pragma.
9505 -- Such homonyms might be present in the context of other
9506 -- units being compiled.
9510 elsif From_Aspect_Specification
(N
) then
9513 -- If the pragma was created by the compiler, then we don't
9514 -- want it to apply to other homonyms. This kind of case can
9515 -- occur when using pragma Provide_Shift_Operators, which
9516 -- generates implicit shift and rotate operators with Import
9517 -- pragmas that might apply to earlier explicit or implicit
9518 -- declarations marked with Import (for example, coming from
9519 -- an earlier pragma Provide_Shift_Operators for another type),
9520 -- and we don't generally want other homonyms being treated
9521 -- as imported or the pragma flagged as an illegal duplicate.
9523 elsif not Comes_From_Source
(N
) then
9527 Hom_Id
:= Homonym
(Hom_Id
);
9531 -- Import a CPP class
9533 elsif C
= Convention_CPP
9534 and then (Is_Record_Type
(Def_Id
)
9535 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9537 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9538 if Present
(Full_View
(Def_Id
)) then
9539 Def_Id
:= Full_View
(Def_Id
);
9543 ("cannot import 'C'P'P type before full declaration seen",
9544 Get_Pragma_Arg
(Arg2
));
9546 -- Although we have reported the error we decorate it as
9547 -- CPP_Class to avoid reporting spurious errors
9549 Set_Is_CPP_Class
(Def_Id
);
9554 -- Types treated as CPP classes must be declared limited (note:
9555 -- this used to be a warning but there is no real benefit to it
9556 -- since we did effectively intend to treat the type as limited
9559 if not Is_Limited_Type
(Def_Id
) then
9561 ("imported 'C'P'P type must be limited",
9562 Get_Pragma_Arg
(Arg2
));
9565 if Etype
(Def_Id
) /= Def_Id
9566 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9568 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9571 Set_Is_CPP_Class
(Def_Id
);
9573 -- Imported CPP types must not have discriminants (because C++
9574 -- classes do not have discriminants).
9576 if Has_Discriminants
(Def_Id
) then
9578 ("imported 'C'P'P type cannot have discriminants",
9579 First
(Discriminant_Specifications
9580 (Declaration_Node
(Def_Id
))));
9583 -- Check that components of imported CPP types do not have default
9584 -- expressions. For private types this check is performed when the
9585 -- full view is analyzed (see Process_Full_View).
9587 if not Is_Private_Type
(Def_Id
) then
9588 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9591 -- Import a CPP exception
9593 elsif C
= Convention_CPP
9594 and then Ekind
(Def_Id
) = E_Exception
9598 ("'External_'Name arguments is required for 'Cpp exception",
9601 -- As only a string is allowed, Check_Arg_Is_External_Name
9604 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9607 if Present
(Arg4
) then
9609 ("Link_Name argument not allowed for imported Cpp exception",
9613 -- Do not call Set_Interface_Name as the name of the exception
9614 -- shouldn't be modified (and in particular it shouldn't be
9615 -- the External_Name). For exceptions, the External_Name is the
9616 -- name of the RTTI structure.
9618 -- ??? Emit an error if pragma Import/Export_Exception is present
9620 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9622 Check_Arg_Count
(3);
9623 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9625 Process_Import_Predefined_Type
;
9627 -- Emit an error unless Relaxed_RM_Semantics since some legacy Ada
9628 -- compilers may accept more cases, e.g. JGNAT allowed importing
9631 elsif not Relaxed_RM_Semantics
then
9632 if From_Aspect_Specification
(N
) then
9634 ("entity for aspect% must be object, subprogram "
9635 & "or incomplete type",
9639 ("second argument of pragma% must be object, subprogram "
9640 & "or incomplete type",
9645 -- If this pragma applies to a compilation unit, then the unit, which
9646 -- is a subprogram, does not require (or allow) a body. We also do
9647 -- not need to elaborate imported procedures.
9649 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9651 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9653 Set_Body_Required
(Cunit
, False);
9656 end Process_Import_Or_Interface
;
9658 --------------------
9659 -- Process_Inline --
9660 --------------------
9662 procedure Process_Inline
(Status
: Inline_Status
) is
9669 Ghost_Error_Posted
: Boolean := False;
9670 -- Flag set when an error concerning the illegal mix of Ghost and
9671 -- non-Ghost subprograms is emitted.
9673 Ghost_Id
: Entity_Id
:= Empty
;
9674 -- The entity of the first Ghost subprogram encountered while
9675 -- processing the arguments of the pragma.
9677 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9678 -- Verify the placement of pragma Inline_Always with respect to the
9679 -- initial declaration of subprogram Spec_Id.
9681 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9682 -- Returns True if it can be determined at this stage that inlining
9683 -- is not possible, for example if the body is available and contains
9684 -- exception handlers, we prevent inlining, since otherwise we can
9685 -- get undefined symbols at link time. This function also emits a
9686 -- warning if the pragma appears too late.
9688 -- ??? is business with link symbols still valid, or does it relate
9689 -- to front end ZCX which is being phased out ???
9691 procedure Make_Inline
(Subp
: Entity_Id
);
9692 -- Subp is the defining unit name of the subprogram declaration. If
9693 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9694 -- the corresponding body, if there is one present.
9696 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9697 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9698 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9700 -----------------------------------
9701 -- Check_Inline_Always_Placement --
9702 -----------------------------------
9704 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9705 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9707 function Compilation_Unit_OK
return Boolean;
9708 pragma Inline
(Compilation_Unit_OK
);
9709 -- Determine whether pragma Inline_Always applies to a compatible
9710 -- compilation unit denoted by Spec_Id.
9712 function Declarative_List_OK
return Boolean;
9713 pragma Inline
(Declarative_List_OK
);
9714 -- Determine whether the initial declaration of subprogram Spec_Id
9715 -- and the pragma appear in compatible declarative lists.
9717 function Subprogram_Body_OK
return Boolean;
9718 pragma Inline
(Subprogram_Body_OK
);
9719 -- Determine whether pragma Inline_Always applies to a compatible
9720 -- subprogram body denoted by Spec_Id.
9722 -------------------------
9723 -- Compilation_Unit_OK --
9724 -------------------------
9726 function Compilation_Unit_OK
return Boolean is
9727 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9730 -- The pragma appears after the initial declaration of a
9731 -- compilation unit.
9733 -- procedure Comp_Unit;
9734 -- pragma Inline_Always (Comp_Unit);
9736 -- Note that for compatibility reasons, the following case is
9739 -- procedure Stand_Alone_Body_Comp_Unit is
9741 -- end Stand_Alone_Body_Comp_Unit;
9742 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9745 Nkind
(Comp_Unit
) = N_Compilation_Unit
9746 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9747 and then Is_List_Member
(N
)
9748 and then List_Containing
(N
) =
9749 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9750 end Compilation_Unit_OK
;
9752 -------------------------
9753 -- Declarative_List_OK --
9754 -------------------------
9756 function Declarative_List_OK
return Boolean is
9757 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9759 Init_Decl
: Node_Id
;
9760 Init_List
: List_Id
;
9761 Prag_List
: List_Id
;
9764 -- Determine the proper initial declaration. In general this is
9765 -- the declaration node of the subprogram except when the input
9766 -- denotes a generic instantiation.
9768 -- procedure Inst is new Gen;
9769 -- pragma Inline_Always (Inst);
9771 -- In this case the original subprogram is moved inside an
9772 -- anonymous package while pragma Inline_Always remains at the
9773 -- level of the anonymous package. Use the declaration of the
9774 -- package because it reflects the placement of the original
9777 -- package Anon_Pack is
9778 -- procedure Inst is ... end Inst; -- original
9781 -- procedure Inst renames Anon_Pack.Inst;
9782 -- pragma Inline_Always (Inst);
9784 if Is_Generic_Instance
(Spec_Id
) then
9785 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9786 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9788 Init_Decl
:= Spec_Decl
;
9791 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9792 Init_List
:= List_Containing
(Init_Decl
);
9793 Prag_List
:= List_Containing
(N
);
9795 -- The pragma and then initial declaration appear within the
9796 -- same declarative list.
9798 if Init_List
= Prag_List
then
9801 -- A special case of the above is when both the pragma and
9802 -- the initial declaration appear in different lists of a
9803 -- package spec, protected definition, or a task definition.
9808 -- pragma Inline_Always (Proc);
9811 elsif Nkind
(Context
) in N_Package_Specification
9812 | N_Protected_Definition
9814 and then Init_List
= Visible_Declarations
(Context
)
9815 and then Prag_List
= Private_Declarations
(Context
)
9822 end Declarative_List_OK
;
9824 ------------------------
9825 -- Subprogram_Body_OK --
9826 ------------------------
9828 function Subprogram_Body_OK
return Boolean is
9829 Body_Decl
: Node_Id
;
9832 -- The pragma appears within the declarative list of a stand-
9833 -- alone subprogram body.
9835 -- procedure Stand_Alone_Body is
9836 -- pragma Inline_Always (Stand_Alone_Body);
9839 -- end Stand_Alone_Body;
9841 -- The compiler creates a dummy spec in this case, however the
9842 -- pragma remains within the declarative list of the body.
9844 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9845 and then not Comes_From_Source
(Spec_Decl
)
9846 and then Present
(Corresponding_Body
(Spec_Decl
))
9849 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9851 if Present
(Declarations
(Body_Decl
))
9852 and then Is_List_Member
(N
)
9853 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9860 end Subprogram_Body_OK
;
9862 -- Start of processing for Check_Inline_Always_Placement
9865 -- This check is relevant only for pragma Inline_Always
9867 if Pname
/= Name_Inline_Always
then
9870 -- Nothing to do when the pragma is internally generated on the
9871 -- assumption that it is properly placed.
9873 elsif not Comes_From_Source
(N
) then
9876 -- Nothing to do for internally generated subprograms that act
9877 -- as accidental homonyms of a source subprogram being inlined.
9879 elsif not Comes_From_Source
(Spec_Id
) then
9882 -- Nothing to do for generic formal subprograms that act as
9883 -- homonyms of another source subprogram being inlined.
9885 elsif Is_Formal_Subprogram
(Spec_Id
) then
9888 elsif Compilation_Unit_OK
9889 or else Declarative_List_OK
9890 or else Subprogram_Body_OK
9895 -- At this point it is known that the pragma applies to or appears
9896 -- within a completing body, a completing stub, or a subunit.
9898 Error_Msg_Name_1
:= Pname
;
9899 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9900 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9903 ("pragma % must appear on initial declaration of subprogram "
9904 & "% defined #", N
);
9905 end Check_Inline_Always_Placement
;
9907 ---------------------------
9908 -- Inlining_Not_Possible --
9909 ---------------------------
9911 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9912 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9916 if Nkind
(Decl
) = N_Subprogram_Body
then
9917 Stats
:= Handled_Statement_Sequence
(Decl
);
9918 return Present
(Exception_Handlers
(Stats
))
9919 or else Present
(At_End_Proc
(Stats
));
9921 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9922 and then Present
(Corresponding_Body
(Decl
))
9924 if Analyzed
(Corresponding_Body
(Decl
)) then
9925 Error_Msg_N
("pragma appears too late, ignored??", N
);
9928 -- If the subprogram is a renaming as body, the body is just a
9929 -- call to the renamed subprogram, and inlining is trivially
9933 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9934 N_Subprogram_Renaming_Declaration
9940 Handled_Statement_Sequence
9941 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9944 Present
(Exception_Handlers
(Stats
))
9945 or else Present
(At_End_Proc
(Stats
));
9949 -- If body is not available, assume the best, the check is
9950 -- performed again when compiling enclosing package bodies.
9954 end Inlining_Not_Possible
;
9960 procedure Make_Inline
(Subp
: Entity_Id
) is
9961 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9962 Inner_Subp
: Entity_Id
:= Subp
;
9965 -- Ignore if bad type, avoid cascaded error
9967 if Etype
(Subp
) = Any_Type
then
9971 -- If inlining is not possible, for now do not treat as an error
9973 elsif Status
/= Suppressed
9974 and then Front_End_Inlining
9975 and then Inlining_Not_Possible
(Subp
)
9980 -- Here we have a candidate for inlining, but we must exclude
9981 -- derived operations. Otherwise we would end up trying to inline
9982 -- a phantom declaration, and the result would be to drag in a
9983 -- body which has no direct inlining associated with it. That
9984 -- would not only be inefficient but would also result in the
9985 -- backend doing cross-unit inlining in cases where it was
9986 -- definitely inappropriate to do so.
9988 -- However, a simple Comes_From_Source test is insufficient, since
9989 -- we do want to allow inlining of generic instances which also do
9990 -- not come from source. We also need to recognize specs generated
9991 -- by the front-end for bodies that carry the pragma. Finally,
9992 -- predefined operators do not come from source but are not
9993 -- inlineable either.
9995 elsif Is_Generic_Instance
(Subp
)
9996 or else Parent_Kind
(Parent
(Subp
)) = N_Subprogram_Declaration
10000 elsif not Comes_From_Source
(Subp
)
10001 and then Scope
(Subp
) /= Standard_Standard
10007 -- The referenced entity must either be the enclosing entity, or
10008 -- an entity declared within the current open scope.
10010 if Present
(Scope
(Subp
))
10011 and then Scope
(Subp
) /= Current_Scope
10012 and then Subp
/= Current_Scope
10015 ("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 Restriction_Id
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
));
10833 Analyze_And_Resolve
(Expr
, Any_Integer
);
10835 if R_Id
not in All_Parameter_Restrictions
then
10837 ("invalid restriction parameter identifier", Arg
);
10839 elsif not Is_OK_Static_Expression
(Expr
) then
10840 Flag_Non_Static_Expr
10841 ("value must be static expression!", Expr
);
10844 elsif not Is_Integer_Type
(Etype
(Expr
))
10845 or else Expr_Value
(Expr
) < 0
10848 ("value must be non-negative integer", Arg
);
10851 -- Restriction pragma is active
10853 Val
:= Expr_Value
(Expr
);
10855 if not UI_Is_In_Int_Range
(Val
) then
10857 ("pragma ignored, value too large??", Arg
);
10860 Set_Restriction
(R_Id
, N
, Warn
, Integer (UI_To_Int
(Val
)));
10865 end Process_Restrictions_Or_Restriction_Warnings
;
10867 ---------------------------------
10868 -- Process_Suppress_Unsuppress --
10869 ---------------------------------
10871 -- Note: this procedure makes entries in the check suppress data
10872 -- structures managed by Sem. See spec of package Sem for full
10873 -- details on how we handle recording of check suppression.
10875 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10880 In_Package_Spec
: constant Boolean :=
10881 Is_Package_Or_Generic_Package
(Current_Scope
)
10882 and then not In_Package_Body
(Current_Scope
);
10884 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10885 -- Used to suppress a single check on the given entity
10887 --------------------------------
10888 -- Suppress_Unsuppress_Echeck --
10889 --------------------------------
10891 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10893 -- Check for error of trying to set atomic synchronization for
10894 -- a non-atomic variable.
10896 if C
= Atomic_Synchronization
10897 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10900 ("pragma & requires atomic type or variable",
10901 Pragma_Identifier
(Original_Node
(N
)));
10904 Set_Checks_May_Be_Suppressed
(E
);
10906 if In_Package_Spec
then
10907 Push_Global_Suppress_Stack_Entry
10910 Suppress
=> Suppress_Case
);
10912 Push_Local_Suppress_Stack_Entry
10915 Suppress
=> Suppress_Case
);
10918 -- If this is a first subtype, and the base type is distinct,
10919 -- then also set the suppress flags on the base type.
10921 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10922 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10924 end Suppress_Unsuppress_Echeck
;
10926 -- Start of processing for Process_Suppress_Unsuppress
10929 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10930 -- on user code: we want to generate checks for analysis purposes, as
10931 -- set respectively by -gnatC and -gnatd.F
10933 if Comes_From_Source
(N
)
10934 and then (CodePeer_Mode
or GNATprove_Mode
)
10939 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10940 -- declarative part or a package spec (RM 11.5(5)).
10942 if not Is_Configuration_Pragma
then
10943 Check_Is_In_Decl_Part_Or_Package_Spec
;
10946 Check_At_Least_N_Arguments
(1);
10947 Check_At_Most_N_Arguments
(2);
10948 Check_No_Identifier
(Arg1
);
10949 Check_Arg_Is_Identifier
(Arg1
);
10951 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10953 if C
= No_Check_Id
then
10955 ("argument of pragma% is not valid check name", Arg1
);
10958 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10960 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10962 ("Suppress of Elaboration_Check ignored in SPARK??",
10963 "\elaboration checking rules are statically enforced "
10964 & "(SPARK RM 7.7)", Arg1
);
10967 -- One-argument case
10969 if Arg_Count
= 1 then
10971 -- Make an entry in the local scope suppress table. This is the
10972 -- table that directly shows the current value of the scope
10973 -- suppress check for any check id value.
10975 if C
= All_Checks
then
10977 -- For All_Checks, we set all specific predefined checks with
10978 -- the exception of Elaboration_Check, which is handled
10979 -- specially because of not wanting All_Checks to have the
10980 -- effect of deactivating static elaboration order processing.
10981 -- Atomic_Synchronization is also not affected, since this is
10982 -- not a real check.
10984 for J
in Scope_Suppress
.Suppress
'Range loop
10985 if J
/= Elaboration_Check
10987 J
/= Atomic_Synchronization
10989 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10993 -- If not All_Checks, and predefined check, then set appropriate
10994 -- scope entry. Note that we will set Elaboration_Check if this
10995 -- is explicitly specified. Atomic_Synchronization is allowed
10996 -- only if internally generated and entity is atomic.
10998 elsif C
in Predefined_Check_Id
10999 and then (not Comes_From_Source
(N
)
11000 or else C
/= Atomic_Synchronization
)
11002 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
11005 -- Also make an entry in the Local_Entity_Suppress table
11007 Push_Local_Suppress_Stack_Entry
11010 Suppress
=> Suppress_Case
);
11012 -- Case of two arguments present, where the check is suppressed for
11013 -- a specified entity (given as the second argument of the pragma)
11016 -- This is obsolescent in Ada 2005 mode
11018 if Ada_Version
>= Ada_2005
then
11019 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
11022 Check_Optional_Identifier
(Arg2
, Name_On
);
11023 E_Id
:= Get_Pragma_Arg
(Arg2
);
11026 if not Is_Entity_Name
(E_Id
) then
11028 ("second argument of pragma% must be entity name", Arg2
);
11031 E
:= Entity
(E_Id
);
11037 -- A pragma that applies to a Ghost entity becomes Ghost for the
11038 -- purposes of legality checks and removal of ignored Ghost code.
11040 Mark_Ghost_Pragma
(N
, E
);
11042 -- Enforce RM 11.5(7) which requires that for a pragma that
11043 -- appears within a package spec, the named entity must be
11044 -- within the package spec. We allow the package name itself
11045 -- to be mentioned since that makes sense, although it is not
11046 -- strictly allowed by 11.5(7).
11049 and then E
/= Current_Scope
11050 and then Scope
(E
) /= Current_Scope
11053 ("entity in pragma% is not in package spec (RM 11.5(7))",
11057 -- Loop through homonyms. As noted below, in the case of a package
11058 -- spec, only homonyms within the package spec are considered.
11061 Suppress_Unsuppress_Echeck
(E
, C
);
11063 if Is_Generic_Instance
(E
)
11064 and then Is_Subprogram
(E
)
11065 and then Present
(Alias
(E
))
11067 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
11070 -- Move to next homonym if not aspect spec case
11072 exit when From_Aspect_Specification
(N
);
11076 -- If we are within a package specification, the pragma only
11077 -- applies to homonyms in the same scope.
11079 exit when In_Package_Spec
11080 and then Scope
(E
) /= Current_Scope
;
11083 end Process_Suppress_Unsuppress
;
11085 -------------------------------
11086 -- Record_Independence_Check --
11087 -------------------------------
11089 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
11090 pragma Unreferenced
(N
, E
);
11092 -- For GCC back ends the validation is done a priori. This code is
11093 -- dead, but might be useful in the future.
11095 -- if not AAMP_On_Target then
11099 -- Independence_Checks.Append ((N, E));
11102 end Record_Independence_Check
;
11108 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
11110 if Is_Imported
(E
) then
11112 ("cannot export entity& that was previously imported", Arg
);
11114 elsif Present
(Address_Clause
(E
))
11115 and then not Relaxed_RM_Semantics
11118 ("cannot export entity& that has an address clause", Arg
);
11121 Set_Is_Exported
(E
);
11123 -- Generate a reference for entity explicitly, because the
11124 -- identifier may be overloaded and name resolution will not
11127 Generate_Reference
(E
, Arg
);
11129 -- Deal with exporting non-library level entity
11131 if not Is_Library_Level_Entity
(E
) then
11133 -- Not allowed at all for subprograms
11135 if Is_Subprogram
(E
) then
11136 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
11138 -- Otherwise set public and statically allocated
11142 Set_Is_Statically_Allocated
(E
);
11144 -- Warn if the corresponding W flag is set
11146 if Warn_On_Export_Import
11148 -- Only do this for something that was in the source. Not
11149 -- clear if this can be False now (there used for sure to be
11150 -- cases on some systems where it was False), but anyway the
11151 -- test is harmless if not needed, so it is retained.
11153 and then Comes_From_Source
(Arg
)
11156 ("?x?& has been made static as a result of Export",
11159 ("\?x?this usage is non-standard and non-portable",
11165 if Warn_On_Export_Import
and Inside_A_Generic
then
11167 ("all instances of& will have the same external name?x?",
11172 ----------------------------------------------
11173 -- Set_Extended_Import_Export_External_Name --
11174 ----------------------------------------------
11176 procedure Set_Extended_Import_Export_External_Name
11177 (Internal_Ent
: Entity_Id
;
11178 Arg_External
: Node_Id
)
11180 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
11181 New_Name
: Node_Id
;
11184 if No
(Arg_External
) then
11188 Check_Arg_Is_External_Name
(Arg_External
);
11190 if Nkind
(Arg_External
) = N_String_Literal
then
11191 if String_Length
(Strval
(Arg_External
)) = 0 then
11194 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
11197 elsif Nkind
(Arg_External
) = N_Identifier
then
11198 New_Name
:= Get_Default_External_Name
(Arg_External
);
11200 -- Check_Arg_Is_External_Name should let through only identifiers and
11201 -- string literals or static string expressions (which are folded to
11202 -- string literals).
11205 raise Program_Error
;
11208 -- If we already have an external name set (by a prior normal Import
11209 -- or Export pragma), then the external names must match
11211 if Present
(Interface_Name
(Internal_Ent
)) then
11213 -- Ignore mismatching names in CodePeer mode, to support some
11214 -- old compilers which would export the same procedure under
11215 -- different names, e.g:
11217 -- pragma Export_Procedure (P, "a");
11218 -- pragma Export_Procedure (P, "b");
11220 if CodePeer_Mode
then
11224 Check_Matching_Internal_Names
: declare
11225 S1
: constant String_Id
:= Strval
(Old_Name
);
11226 S2
: constant String_Id
:= Strval
(New_Name
);
11228 procedure Mismatch
;
11229 pragma No_Return
(Mismatch
);
11230 -- Called if names do not match
11236 procedure Mismatch
is
11238 Error_Msg_Sloc
:= Sloc
(Old_Name
);
11240 ("external name does not match that given #",
11244 -- Start of processing for Check_Matching_Internal_Names
11247 if String_Length
(S1
) /= String_Length
(S2
) then
11251 for J
in 1 .. String_Length
(S1
) loop
11252 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
11257 end Check_Matching_Internal_Names
;
11259 -- Otherwise set the given name
11262 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
11263 Check_Duplicated_Export_Name
(New_Name
);
11265 end Set_Extended_Import_Export_External_Name
;
11271 procedure Set_Imported
(E
: Entity_Id
) is
11273 -- Error message if already imported or exported
11275 if Is_Exported
(E
) or else Is_Imported
(E
) then
11277 -- Error if being set Exported twice
11279 if Is_Exported
(E
) then
11280 Error_Msg_NE
("entity& was previously exported", N
, E
);
11282 -- Ignore error in CodePeer mode where we treat all imported
11283 -- subprograms as unknown.
11285 elsif CodePeer_Mode
then
11288 -- OK if Import/Interface case
11290 elsif Import_Interface_Present
(N
) then
11293 -- Error if being set Imported twice
11296 Error_Msg_NE
("entity& was previously imported", N
, E
);
11299 Error_Msg_Name_1
:= Pname
;
11301 ("\(pragma% applies to all previous entities)", N
);
11303 Error_Msg_Sloc
:= Sloc
(E
);
11304 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
11306 -- Here if not previously imported or exported, OK to import
11309 Set_Is_Imported
(E
);
11311 -- For subprogram, set Import_Pragma field
11313 if Is_Subprogram
(E
) then
11314 Set_Import_Pragma
(E
, N
);
11317 -- If the entity is an object that is not at the library level,
11318 -- then it is statically allocated. We do not worry about objects
11319 -- with address clauses in this context since they are not really
11320 -- imported in the linker sense.
11323 and then not Is_Library_Level_Entity
(E
)
11324 and then No
(Address_Clause
(E
))
11326 Set_Is_Statically_Allocated
(E
);
11333 -------------------------
11334 -- Set_Mechanism_Value --
11335 -------------------------
11337 -- Note: the mechanism name has not been analyzed (and cannot indeed be
11338 -- analyzed, since it is semantic nonsense), so we get it in the exact
11339 -- form created by the parser.
11341 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
11342 procedure Bad_Mechanism
;
11343 pragma No_Return
(Bad_Mechanism
);
11344 -- Signal bad mechanism name
11346 -------------------
11347 -- Bad_Mechanism --
11348 -------------------
11350 procedure Bad_Mechanism
is
11352 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
11355 -- Start of processing for Set_Mechanism_Value
11358 if Mechanism
(Ent
) /= Default_Mechanism
then
11360 ("mechanism for & has already been set", Mech_Name
, Ent
);
11363 -- MECHANISM_NAME ::= value | reference
11365 if Nkind
(Mech_Name
) = N_Identifier
then
11366 if Chars
(Mech_Name
) = Name_Value
then
11367 Set_Mechanism
(Ent
, By_Copy
);
11370 elsif Chars
(Mech_Name
) = Name_Reference
then
11371 Set_Mechanism
(Ent
, By_Reference
);
11374 elsif Chars
(Mech_Name
) = Name_Copy
then
11376 ("bad mechanism name, Value assumed", Mech_Name
);
11385 end Set_Mechanism_Value
;
11387 --------------------------
11388 -- Set_Rational_Profile --
11389 --------------------------
11391 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
11392 -- extension to the semantics of renaming declarations.
11394 procedure Set_Rational_Profile
is
11396 Implicit_Packing
:= True;
11397 Overriding_Renamings
:= True;
11398 Use_VADS_Size
:= True;
11399 end Set_Rational_Profile
;
11401 ---------------------------
11402 -- Set_Ravenscar_Profile --
11403 ---------------------------
11405 -- The tasks to be done here are
11407 -- Set required policies
11409 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11410 -- (For Ravenscar, Jorvik, and GNAT_Extended_Ravenscar profiles)
11411 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11412 -- (For GNAT_Ravenscar_EDF profile)
11413 -- pragma Locking_Policy (Ceiling_Locking)
11415 -- Set Detect_Blocking mode
11417 -- Set required restrictions (see System.Rident for detailed list)
11419 -- Set the No_Dependence rules
11420 -- No_Dependence => Ada.Asynchronous_Task_Control
11421 -- No_Dependence => Ada.Calendar
11422 -- No_Dependence => Ada.Execution_Time.Group_Budget
11423 -- No_Dependence => Ada.Execution_Time.Timers
11424 -- No_Dependence => Ada.Task_Attributes
11425 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11427 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11428 procedure Set_Error_Msg_To_Profile_Name
;
11429 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11432 -----------------------------------
11433 -- Set_Error_Msg_To_Profile_Name --
11434 -----------------------------------
11436 procedure Set_Error_Msg_To_Profile_Name
is
11437 Prof_Nam
: constant Node_Id
:=
11439 (First
(Pragma_Argument_Associations
(N
)));
11442 Get_Name_String
(Chars
(Prof_Nam
));
11443 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11444 Error_Msg_Strlen
:= Name_Len
;
11445 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11446 end Set_Error_Msg_To_Profile_Name
;
11448 Profile_Dispatching_Policy
: Character;
11450 -- Start of processing for Set_Ravenscar_Profile
11453 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11455 if Profile
= GNAT_Ravenscar_EDF
then
11456 Profile_Dispatching_Policy
:= 'E';
11458 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11461 Profile_Dispatching_Policy
:= 'F';
11464 if Task_Dispatching_Policy
/= ' '
11465 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11467 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11468 Set_Error_Msg_To_Profile_Name
;
11469 Error_Pragma
("Profile (~) incompatible with policy#");
11471 -- Set the FIFO_Within_Priorities policy, but always preserve
11472 -- System_Location since we like the error message with the run time
11476 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11478 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11479 Task_Dispatching_Policy_Sloc
:= Loc
;
11483 -- pragma Locking_Policy (Ceiling_Locking)
11485 if Locking_Policy
/= ' '
11486 and then Locking_Policy
/= 'C'
11488 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11489 Set_Error_Msg_To_Profile_Name
;
11490 Error_Pragma
("Profile (~) incompatible with policy#");
11492 -- Set the Ceiling_Locking policy, but preserve System_Location since
11493 -- we like the error message with the run time name.
11496 Locking_Policy
:= 'C';
11498 if Locking_Policy_Sloc
/= System_Location
then
11499 Locking_Policy_Sloc
:= Loc
;
11503 -- pragma Detect_Blocking
11505 Detect_Blocking
:= True;
11507 -- Set the corresponding restrictions
11509 Set_Profile_Restrictions
11510 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11512 -- Set the No_Dependence restrictions
11514 -- The following No_Dependence restrictions:
11515 -- No_Dependence => Ada.Asynchronous_Task_Control
11516 -- No_Dependence => Ada.Calendar
11517 -- No_Dependence => Ada.Task_Attributes
11518 -- are already set by previous call to Set_Profile_Restrictions.
11521 -- Set the following restrictions which were added to Ada 2005:
11522 -- No_Dependence => Ada.Execution_Time.Group_Budget
11523 -- No_Dependence => Ada.Execution_Time.Timers
11525 if Ada_Version
>= Ada_2005
then
11527 Execution_Time
: constant Node_Id
:=
11528 Sel_Comp
("ada", "execution_time", Loc
);
11529 Group_Budgets
: constant Node_Id
:=
11530 Sel_Comp
(Execution_Time
, "group_budgets");
11531 Timers
: constant Node_Id
:=
11532 Sel_Comp
(Execution_Time
, "timers");
11534 Set_Restriction_No_Dependence
11535 (Unit
=> Group_Budgets
,
11536 Warn
=> Treat_Restrictions_As_Warnings
,
11537 Profile
=> Ravenscar
);
11538 Set_Restriction_No_Dependence
11540 Warn
=> Treat_Restrictions_As_Warnings
,
11541 Profile
=> Ravenscar
);
11545 -- Set the following restriction which was added to Ada 2012 (see
11547 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11549 if Ada_Version
>= Ada_2012
then
11550 Set_Restriction_No_Dependence
11552 (Sel_Comp
("system", "multiprocessors", Loc
),
11553 "dispatching_domains"),
11554 Warn
=> Treat_Restrictions_As_Warnings
,
11555 Profile
=> Ravenscar
);
11557 -- Set the following restriction which was added to Ada 2022,
11558 -- but as a binding interpretation:
11559 -- No_Dependence => Ada.Synchronous_Barriers
11560 -- for Ravenscar (and therefore for Ravenscar variants) but not
11561 -- for Jorvik. The unit Ada.Synchronous_Barriers was introduced
11562 -- in Ada2012 (AI05-0174).
11564 if Profile
/= Jorvik
then
11565 Set_Restriction_No_Dependence
11566 (Sel_Comp
("ada", "synchronous_barriers", Loc
),
11567 Warn
=> Treat_Restrictions_As_Warnings
,
11568 Profile
=> Ravenscar
);
11572 end Set_Ravenscar_Profile
;
11574 -- Start of processing for Analyze_Pragma
11577 -- The following code is a defense against recursion. Not clear that
11578 -- this can happen legitimately, but perhaps some error situations can
11579 -- cause it, and we did see this recursion during testing.
11581 if Analyzed
(N
) then
11587 Check_Restriction_No_Use_Of_Pragma
(N
);
11589 if Is_Aspect_Id
(Chars
(Pragma_Identifier
(N
))) then
11590 -- 6.1/3 No_Specification_of_Aspect: Identifies an aspect for which
11591 -- no aspect_specification, attribute_definition_clause, or pragma
11593 Check_Restriction_No_Specification_Of_Aspect
(N
);
11596 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11597 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11599 if Should_Ignore_Pragma_Sem
(N
)
11600 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11601 and then Ignore_Rep_Clauses
)
11606 -- Deal with unrecognized pragma
11608 if not Is_Pragma_Name
(Pname
) then
11610 Msg_Issued
: Boolean := False;
11613 (Msg_Issued
, No_Unrecognized_Pragmas
, Pragma_Identifier
(N
));
11614 if not Msg_Issued
and then Warn_On_Unrecognized_Pragma
then
11615 Error_Msg_Name_1
:= Pname
;
11616 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11618 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11619 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11620 Error_Msg_Name_1
:= PN
;
11621 Error_Msg_N
-- CODEFIX
11622 ("\?g?possible misspelling of %!",
11623 Pragma_Identifier
(N
));
11633 -- Here to start processing for recognized pragma
11635 Pname
:= Original_Aspect_Pragma_Name
(N
);
11637 -- Capture setting of Opt.Uneval_Old
11639 case Opt
.Uneval_Old
is
11641 Set_Uneval_Old_Accept
(N
);
11647 Set_Uneval_Old_Warn
(N
);
11650 raise Program_Error
;
11653 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11654 -- is already set, indicating that we have already checked the policy
11655 -- at the right point. This happens for example in the case of a pragma
11656 -- that is derived from an Aspect.
11658 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11661 -- For a pragma that is a rewriting of another pragma, copy the
11662 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11664 elsif Is_Rewrite_Substitution
(N
)
11665 and then Nkind
(Original_Node
(N
)) = N_Pragma
11667 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11668 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11670 -- Otherwise query the applicable policy at this point
11673 Check_Applicable_Policy
(N
);
11675 -- If pragma is disabled, rewrite as NULL and skip analysis
11677 if Is_Disabled
(N
) then
11678 Rewrite
(N
, Make_Null_Statement
(Loc
));
11684 -- Mark assertion pragmas as Ghost depending on their enclosing context
11686 if Assertion_Expression_Pragma
(Prag_Id
) then
11687 Mark_Ghost_Pragma
(N
, Current_Scope
);
11690 -- Preset arguments
11699 if Present
(Pragma_Argument_Associations
(N
)) then
11700 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11701 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11703 if Present
(Arg1
) then
11704 Arg2
:= Next
(Arg1
);
11706 if Present
(Arg2
) then
11707 Arg3
:= Next
(Arg2
);
11709 if Present
(Arg3
) then
11710 Arg4
:= Next
(Arg3
);
11712 if Present
(Arg4
) then
11713 Arg5
:= Next
(Arg4
);
11720 -- An enumeration type defines the pragmas that are supported by the
11721 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11722 -- into the corresponding enumeration value for the following case.
11730 -- pragma Abort_Defer;
11732 when Pragma_Abort_Defer
=>
11734 Check_Arg_Count
(0);
11736 -- The only required semantic processing is to check the
11737 -- placement. This pragma must appear at the start of the
11738 -- statement sequence of a handled sequence of statements.
11740 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11741 or else N
/= First
(Statements
(Parent
(N
)))
11746 --------------------
11747 -- Abstract_State --
11748 --------------------
11750 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11752 -- ABSTRACT_STATE_LIST ::=
11754 -- | STATE_NAME_WITH_OPTIONS
11755 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11757 -- STATE_NAME_WITH_OPTIONS ::=
11759 -- | (STATE_NAME with OPTION_LIST)
11761 -- OPTION_LIST ::= OPTION {, OPTION}
11765 -- | NAME_VALUE_OPTION
11767 -- SIMPLE_OPTION ::= Ghost | Relaxed_Initialization | Synchronous
11769 -- NAME_VALUE_OPTION ::=
11770 -- Part_Of => ABSTRACT_STATE
11771 -- | External [=> EXTERNAL_PROPERTY_LIST]
11773 -- EXTERNAL_PROPERTY_LIST ::=
11774 -- EXTERNAL_PROPERTY
11775 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11777 -- EXTERNAL_PROPERTY ::=
11778 -- Async_Readers [=> boolean_EXPRESSION]
11779 -- | Async_Writers [=> boolean_EXPRESSION]
11780 -- | Effective_Reads [=> boolean_EXPRESSION]
11781 -- | Effective_Writes [=> boolean_EXPRESSION]
11782 -- others => boolean_EXPRESSION
11784 -- STATE_NAME ::= defining_identifier
11786 -- ABSTRACT_STATE ::= name
11788 -- Characteristics:
11790 -- * Analysis - The annotation is fully analyzed immediately upon
11791 -- elaboration as it cannot forward reference entities.
11793 -- * Expansion - None.
11795 -- * Template - The annotation utilizes the generic template of the
11796 -- related package declaration.
11798 -- * Globals - The annotation cannot reference global entities.
11800 -- * Instance - The annotation is instantiated automatically when
11801 -- the related generic package is instantiated.
11803 when Pragma_Abstract_State
=> Abstract_State
: declare
11804 Missing_Parentheses
: Boolean := False;
11805 -- Flag set when a state declaration with options is not properly
11808 -- Flags used to verify the consistency of states
11810 Non_Null_Seen
: Boolean := False;
11811 Null_Seen
: Boolean := False;
11813 procedure Analyze_Abstract_State
11815 Pack_Id
: Entity_Id
);
11816 -- Verify the legality of a single state declaration. Create and
11817 -- decorate a state abstraction entity and introduce it into the
11818 -- visibility chain. Pack_Id denotes the entity or the related
11819 -- package where pragma Abstract_State appears.
11821 procedure Malformed_State_Error
(State
: Node_Id
);
11822 -- Emit an error concerning the illegal declaration of abstract
11823 -- state State. This routine diagnoses syntax errors that lead to
11824 -- a different parse tree. The error is issued regardless of the
11825 -- SPARK mode in effect.
11827 ----------------------------
11828 -- Analyze_Abstract_State --
11829 ----------------------------
11831 procedure Analyze_Abstract_State
11833 Pack_Id
: Entity_Id
)
11835 -- Flags used to verify the consistency of options
11837 AR_Seen
: Boolean := False;
11838 AW_Seen
: Boolean := False;
11839 ER_Seen
: Boolean := False;
11840 EW_Seen
: Boolean := False;
11841 External_Seen
: Boolean := False;
11842 Ghost_Seen
: Boolean := False;
11843 Others_Seen
: Boolean := False;
11844 Part_Of_Seen
: Boolean := False;
11845 Relaxed_Initialization_Seen
: Boolean := False;
11846 Synchronous_Seen
: Boolean := False;
11848 -- Flags used to store the static value of all external states'
11851 AR_Val
: Boolean := False;
11852 AW_Val
: Boolean := False;
11853 ER_Val
: Boolean := False;
11854 EW_Val
: Boolean := False;
11856 State_Id
: Entity_Id
:= Empty
;
11857 -- The entity to be generated for the current state declaration
11859 procedure Analyze_External_Option
(Opt
: Node_Id
);
11860 -- Verify the legality of option External
11862 procedure Analyze_External_Property
11864 Expr
: Node_Id
:= Empty
);
11865 -- Verify the legailty of a single external property. Prop
11866 -- denotes the external property. Expr is the expression used
11867 -- to set the property.
11869 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11870 -- Verify the legality of option Part_Of
11872 procedure Check_Duplicate_Option
11874 Status
: in out Boolean);
11875 -- Flag Status denotes whether a particular option has been
11876 -- seen while processing a state. This routine verifies that
11877 -- Opt is not a duplicate option and sets the flag Status
11878 -- (SPARK RM 7.1.4(1)).
11880 procedure Check_Duplicate_Property
11882 Status
: in out Boolean);
11883 -- Flag Status denotes whether a particular property has been
11884 -- seen while processing option External. This routine verifies
11885 -- that Prop is not a duplicate property and sets flag Status.
11886 -- Opt is not a duplicate property and sets the flag Status.
11887 -- (SPARK RM 7.1.4(2))
11889 procedure Check_Ghost_Synchronous
;
11890 -- Ensure that the abstract state is not subject to both Ghost
11891 -- and Synchronous simple options. Emit an error if this is the
11894 procedure Create_Abstract_State
11898 Is_Null
: Boolean);
11899 -- Generate an abstract state entity with name Nam and enter it
11900 -- into visibility. Decl is the "declaration" of the state as
11901 -- it appears in pragma Abstract_State. Loc is the location of
11902 -- the related state "declaration". Flag Is_Null should be set
11903 -- when the associated Abstract_State pragma defines a null
11906 -----------------------------
11907 -- Analyze_External_Option --
11908 -----------------------------
11910 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11911 Errors
: constant Nat
:= Serious_Errors_Detected
;
11913 Props
: Node_Id
:= Empty
;
11916 if Nkind
(Opt
) = N_Component_Association
then
11917 Props
:= Expression
(Opt
);
11920 -- External state with properties
11922 if Present
(Props
) then
11924 -- Multiple properties appear as an aggregate
11926 if Nkind
(Props
) = N_Aggregate
then
11928 -- Simple property form
11930 Prop
:= First
(Expressions
(Props
));
11931 while Present
(Prop
) loop
11932 Analyze_External_Property
(Prop
);
11936 -- Property with expression form
11938 Prop
:= First
(Component_Associations
(Props
));
11939 while Present
(Prop
) loop
11940 Analyze_External_Property
11941 (Prop
=> First
(Choices
(Prop
)),
11942 Expr
=> Expression
(Prop
));
11950 Analyze_External_Property
(Props
);
11953 -- An external state defined without any properties defaults
11954 -- all properties to True.
11963 -- Once all external properties have been processed, verify
11964 -- their mutual interaction. Do not perform the check when
11965 -- at least one of the properties is illegal as this will
11966 -- produce a bogus error.
11968 if Errors
= Serious_Errors_Detected
then
11969 Check_External_Properties
11970 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11972 end Analyze_External_Option
;
11974 -------------------------------
11975 -- Analyze_External_Property --
11976 -------------------------------
11978 procedure Analyze_External_Property
11980 Expr
: Node_Id
:= Empty
)
11982 Expr_Val
: Boolean;
11985 -- Check the placement of "others" (if available)
11987 if Nkind
(Prop
) = N_Others_Choice
then
11988 if Others_Seen
then
11990 ("only one OTHERS choice allowed in option External",
11993 Others_Seen
:= True;
11996 elsif Others_Seen
then
11998 ("OTHERS must be the last property in option External",
12001 -- The only remaining legal options are the four predefined
12002 -- external properties.
12004 elsif Nkind
(Prop
) = N_Identifier
12005 and then Chars
(Prop
) in Name_Async_Readers
12006 | Name_Async_Writers
12007 | Name_Effective_Reads
12008 | Name_Effective_Writes
12012 -- Otherwise the construct is not a valid property
12015 SPARK_Msg_N
("invalid external state property", Prop
);
12019 -- Ensure that the expression of the external state property
12020 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
12022 if Present
(Expr
) then
12023 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
12025 if Is_OK_Static_Expression
(Expr
) then
12026 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
12029 ("expression of external state property must be "
12034 -- The lack of expression defaults the property to True
12040 -- Named properties
12042 if Nkind
(Prop
) = N_Identifier
then
12043 if Chars
(Prop
) = Name_Async_Readers
then
12044 Check_Duplicate_Property
(Prop
, AR_Seen
);
12045 AR_Val
:= Expr_Val
;
12047 elsif Chars
(Prop
) = Name_Async_Writers
then
12048 Check_Duplicate_Property
(Prop
, AW_Seen
);
12049 AW_Val
:= Expr_Val
;
12051 elsif Chars
(Prop
) = Name_Effective_Reads
then
12052 Check_Duplicate_Property
(Prop
, ER_Seen
);
12053 ER_Val
:= Expr_Val
;
12056 Check_Duplicate_Property
(Prop
, EW_Seen
);
12057 EW_Val
:= Expr_Val
;
12060 -- The handling of property "others" must take into account
12061 -- all other named properties that have been encountered so
12062 -- far. Only those that have not been seen are affected by
12066 if not AR_Seen
then
12067 AR_Val
:= Expr_Val
;
12070 if not AW_Seen
then
12071 AW_Val
:= Expr_Val
;
12074 if not ER_Seen
then
12075 ER_Val
:= Expr_Val
;
12078 if not EW_Seen
then
12079 EW_Val
:= Expr_Val
;
12082 end Analyze_External_Property
;
12084 ----------------------------
12085 -- Analyze_Part_Of_Option --
12086 ----------------------------
12088 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
12089 Encap
: constant Node_Id
:= Expression
(Opt
);
12090 Constits
: Elist_Id
;
12091 Encap_Id
: Entity_Id
;
12095 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
12098 (Indic
=> First
(Choices
(Opt
)),
12099 Item_Id
=> State_Id
,
12101 Encap_Id
=> Encap_Id
,
12104 -- The Part_Of indicator transforms the abstract state into
12105 -- a constituent of the encapsulating state or single
12106 -- concurrent type.
12109 pragma Assert
(Present
(Encap_Id
));
12110 Constits
:= Part_Of_Constituents
(Encap_Id
);
12112 if No
(Constits
) then
12113 Constits
:= New_Elmt_List
;
12114 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12117 Append_Elmt
(State_Id
, Constits
);
12118 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12120 end Analyze_Part_Of_Option
;
12122 ----------------------------
12123 -- Check_Duplicate_Option --
12124 ----------------------------
12126 procedure Check_Duplicate_Option
12128 Status
: in out Boolean)
12132 SPARK_Msg_N
("duplicate state option", Opt
);
12136 end Check_Duplicate_Option
;
12138 ------------------------------
12139 -- Check_Duplicate_Property --
12140 ------------------------------
12142 procedure Check_Duplicate_Property
12144 Status
: in out Boolean)
12148 SPARK_Msg_N
("duplicate external property", Prop
);
12152 end Check_Duplicate_Property
;
12154 -----------------------------
12155 -- Check_Ghost_Synchronous --
12156 -----------------------------
12158 procedure Check_Ghost_Synchronous
is
12160 -- A synchronized abstract state cannot be Ghost and vice
12161 -- versa (SPARK RM 6.9(19)).
12163 if Ghost_Seen
and Synchronous_Seen
then
12164 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12166 end Check_Ghost_Synchronous
;
12168 ---------------------------
12169 -- Create_Abstract_State --
12170 ---------------------------
12172 procedure Create_Abstract_State
12179 -- The abstract state may be semi-declared when the related
12180 -- package was withed through a limited with clause. In that
12181 -- case reuse the entity to fully declare the state.
12183 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12184 State_Id
:= Entity
(Decl
);
12186 -- Otherwise the elaboration of pragma Abstract_State
12187 -- declares the state.
12190 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12192 if Present
(Decl
) then
12193 Set_Entity
(Decl
, State_Id
);
12197 -- Null states never come from source
12199 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12200 Set_Parent
(State_Id
, State
);
12201 Mutate_Ekind
(State_Id
, E_Abstract_State
);
12202 Set_Etype
(State_Id
, Standard_Void_Type
);
12203 Set_Encapsulating_State
(State_Id
, Empty
);
12205 -- Set the SPARK mode from the current context
12207 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12208 Set_SPARK_Pragma_Inherited
(State_Id
);
12210 -- An abstract state declared within a Ghost region becomes
12211 -- Ghost (SPARK RM 6.9(2)).
12213 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12214 Set_Is_Ghost_Entity
(State_Id
);
12217 -- Establish a link between the state declaration and the
12218 -- abstract state entity. Note that a null state remains as
12219 -- N_Null and does not carry any linkages.
12221 if not Is_Null
then
12222 if Present
(Decl
) then
12223 Set_Entity
(Decl
, State_Id
);
12224 Set_Etype
(Decl
, Standard_Void_Type
);
12227 -- Every non-null state must be defined, nameable and
12230 Push_Scope
(Pack_Id
);
12231 Generate_Definition
(State_Id
);
12232 Enter_Name
(State_Id
);
12235 end Create_Abstract_State
;
12242 -- Start of processing for Analyze_Abstract_State
12245 -- A package with a null abstract state is not allowed to
12246 -- declare additional states.
12250 ("package & has null abstract state", State
, Pack_Id
);
12252 -- Null states appear as internally generated entities
12254 elsif Nkind
(State
) = N_Null
then
12255 Create_Abstract_State
12256 (Nam
=> New_Internal_Name
('S'),
12258 Loc
=> Sloc
(State
),
12262 -- Catch a case where a null state appears in a list of
12263 -- non-null states.
12265 if Non_Null_Seen
then
12267 ("package & has non-null abstract state",
12271 -- Simple state declaration
12273 elsif Nkind
(State
) = N_Identifier
then
12274 Create_Abstract_State
12275 (Nam
=> Chars
(State
),
12277 Loc
=> Sloc
(State
),
12279 Non_Null_Seen
:= True;
12281 -- State declaration with various options. This construct
12282 -- appears as an extension aggregate in the tree.
12284 elsif Nkind
(State
) = N_Extension_Aggregate
then
12285 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12286 Create_Abstract_State
12287 (Nam
=> Chars
(Ancestor_Part
(State
)),
12288 Decl
=> Ancestor_Part
(State
),
12289 Loc
=> Sloc
(Ancestor_Part
(State
)),
12291 Non_Null_Seen
:= True;
12294 ("state name must be an identifier",
12295 Ancestor_Part
(State
));
12298 -- Options External, Ghost and Synchronous appear as
12301 Opt
:= First
(Expressions
(State
));
12302 while Present
(Opt
) loop
12303 if Nkind
(Opt
) = N_Identifier
then
12307 if Chars
(Opt
) = Name_External
then
12308 Check_Duplicate_Option
(Opt
, External_Seen
);
12309 Analyze_External_Option
(Opt
);
12313 elsif Chars
(Opt
) = Name_Ghost
then
12314 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12315 Check_Ghost_Synchronous
;
12317 if Present
(State_Id
) then
12318 Set_Is_Ghost_Entity
(State_Id
);
12323 elsif Chars
(Opt
) = Name_Synchronous
then
12324 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12325 Check_Ghost_Synchronous
;
12327 -- Relaxed_Initialization
12329 elsif Chars
(Opt
) = Name_Relaxed_Initialization
then
12330 Check_Duplicate_Option
12331 (Opt
, Relaxed_Initialization_Seen
);
12333 -- Option Part_Of without an encapsulating state is
12334 -- illegal (SPARK RM 7.1.4(8)).
12336 elsif Chars
(Opt
) = Name_Part_Of
then
12338 ("indicator Part_Of must denote abstract state, "
12339 & "single protected type or single task type",
12342 -- Do not emit an error message when a previous state
12343 -- declaration with options was not parenthesized as
12344 -- the option is actually another state declaration.
12346 -- with Abstract_State
12347 -- (State_1 with ..., -- missing parentheses
12348 -- (State_2 with ...),
12349 -- State_3) -- ok state declaration
12351 elsif Missing_Parentheses
then
12354 -- Otherwise the option is not allowed. Note that it
12355 -- is not possible to distinguish between an option
12356 -- and a state declaration when a previous state with
12357 -- options not properly parentheses.
12359 -- with Abstract_State
12360 -- (State_1 with ..., -- missing parentheses
12361 -- State_2); -- could be an option
12365 ("simple option not allowed in state declaration",
12369 -- Catch a case where missing parentheses around a state
12370 -- declaration with options cause a subsequent state
12371 -- declaration with options to be treated as an option.
12373 -- with Abstract_State
12374 -- (State_1 with ..., -- missing parentheses
12375 -- (State_2 with ...))
12377 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12378 Missing_Parentheses
:= True;
12380 ("state declaration must be parenthesized",
12381 Ancestor_Part
(State
));
12383 -- Otherwise the option is malformed
12386 SPARK_Msg_N
("malformed option", Opt
);
12392 -- Options External and Part_Of appear as component
12395 Opt
:= First
(Component_Associations
(State
));
12396 while Present
(Opt
) loop
12397 Opt_Nam
:= First
(Choices
(Opt
));
12399 if Nkind
(Opt_Nam
) = N_Identifier
then
12400 if Chars
(Opt_Nam
) = Name_External
then
12401 Analyze_External_Option
(Opt
);
12403 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12404 Analyze_Part_Of_Option
(Opt
);
12407 SPARK_Msg_N
("invalid state option", Opt
);
12410 SPARK_Msg_N
("invalid state option", Opt
);
12416 -- Any other attempt to declare a state is illegal
12419 Malformed_State_Error
(State
);
12423 -- Guard against a junk state. In such cases no entity is
12424 -- generated and the subsequent checks cannot be applied.
12426 if Present
(State_Id
) then
12428 -- Verify whether the state does not introduce an illegal
12429 -- hidden state within a package subject to a null abstract
12432 Check_No_Hidden_State
(State_Id
);
12434 -- Check whether the lack of option Part_Of agrees with the
12435 -- placement of the abstract state with respect to the state
12438 if not Part_Of_Seen
then
12439 Check_Missing_Part_Of
(State_Id
);
12442 -- Associate the state with its related package
12444 if No
(Abstract_States
(Pack_Id
)) then
12445 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12448 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12450 end Analyze_Abstract_State
;
12452 ---------------------------
12453 -- Malformed_State_Error --
12454 ---------------------------
12456 procedure Malformed_State_Error
(State
: Node_Id
) is
12458 Error_Msg_N
("malformed abstract state declaration", State
);
12460 -- An abstract state with a simple option is being declared
12461 -- with "=>" rather than the legal "with". The state appears
12462 -- as a component association.
12464 if Nkind
(State
) = N_Component_Association
then
12465 Error_Msg_N
("\use WITH to specify simple option", State
);
12467 end Malformed_State_Error
;
12471 Pack_Decl
: Node_Id
;
12472 Pack_Id
: Entity_Id
;
12476 -- Start of processing for Abstract_State
12480 Check_No_Identifiers
;
12481 Check_Arg_Count
(1);
12483 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12485 if Nkind
(Pack_Decl
) not in
12486 N_Generic_Package_Declaration | N_Package_Declaration
12492 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12494 -- A pragma that applies to a Ghost entity becomes Ghost for the
12495 -- purposes of legality checks and removal of ignored Ghost code.
12497 Mark_Ghost_Pragma
(N
, Pack_Id
);
12498 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12500 -- Chain the pragma on the contract for completeness
12502 Add_Contract_Item
(N
, Pack_Id
);
12504 -- The legality checks of pragmas Abstract_State, Initializes, and
12505 -- Initial_Condition are affected by the SPARK mode in effect. In
12506 -- addition, these three pragmas are subject to an inherent order:
12508 -- 1) Abstract_State
12510 -- 3) Initial_Condition
12512 -- Analyze all these pragmas in the order outlined above
12514 Analyze_If_Present
(Pragma_SPARK_Mode
);
12515 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12517 -- Multiple non-null abstract states appear as an aggregate
12519 if Nkind
(States
) = N_Aggregate
then
12520 State
:= First
(Expressions
(States
));
12521 while Present
(State
) loop
12522 Analyze_Abstract_State
(State
, Pack_Id
);
12526 -- An abstract state with a simple option is being illegaly
12527 -- declared with "=>" rather than "with". In this case the
12528 -- state declaration appears as a component association.
12530 if Present
(Component_Associations
(States
)) then
12531 State
:= First
(Component_Associations
(States
));
12532 while Present
(State
) loop
12533 Malformed_State_Error
(State
);
12538 -- Various forms of a single abstract state. Note that these may
12539 -- include malformed state declarations.
12542 Analyze_Abstract_State
(States
, Pack_Id
);
12545 Analyze_If_Present
(Pragma_Initializes
);
12546 Analyze_If_Present
(Pragma_Initial_Condition
);
12547 end Abstract_State
;
12555 -- Note: this pragma also has some specific processing in Par.Prag
12556 -- because we want to set the Ada version mode during parsing.
12558 when Pragma_Ada_83
=>
12560 Check_Arg_Count
(0);
12562 -- We really should check unconditionally for proper configuration
12563 -- pragma placement, since we really don't want mixed Ada modes
12564 -- within a single unit, and the GNAT reference manual has always
12565 -- said this was a configuration pragma, but we did not check and
12566 -- are hesitant to add the check now.
12568 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12569 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12570 -- or Ada 2012 mode.
12572 if Ada_Version
>= Ada_2005
then
12573 Check_Valid_Configuration_Pragma
;
12576 -- Now set Ada 83 mode
12578 if Latest_Ada_Only
then
12579 Error_Pragma
("??pragma% ignored");
12581 Ada_Version
:= Ada_83
;
12582 Ada_Version_Explicit
:= Ada_83
;
12583 Ada_Version_Pragma
:= N
;
12592 -- Note: this pragma also has some specific processing in Par.Prag
12593 -- because we want to set the Ada 83 version mode during parsing.
12595 when Pragma_Ada_95
=>
12597 Check_Arg_Count
(0);
12599 -- We really should check unconditionally for proper configuration
12600 -- pragma placement, since we really don't want mixed Ada modes
12601 -- within a single unit, and the GNAT reference manual has always
12602 -- said this was a configuration pragma, but we did not check and
12603 -- are hesitant to add the check now.
12605 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12606 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12608 if Ada_Version
>= Ada_2005
then
12609 Check_Valid_Configuration_Pragma
;
12612 -- Now set Ada 95 mode
12614 if Latest_Ada_Only
then
12615 Error_Pragma
("??pragma% ignored");
12617 Ada_Version
:= Ada_95
;
12618 Ada_Version_Explicit
:= Ada_95
;
12619 Ada_Version_Pragma
:= N
;
12622 ---------------------
12623 -- Ada_05/Ada_2005 --
12624 ---------------------
12627 -- pragma Ada_05 (LOCAL_NAME);
12629 -- pragma Ada_2005;
12630 -- pragma Ada_2005 (LOCAL_NAME):
12632 -- Note: these pragmas also have some specific processing in Par.Prag
12633 -- because we want to set the Ada 2005 version mode during parsing.
12635 -- The one argument form is used for managing the transition from
12636 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12637 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12638 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12639 -- mode, a preference rule is established which does not choose
12640 -- such an entity unless it is unambiguously specified. This avoids
12641 -- extra subprograms marked this way from generating ambiguities in
12642 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12643 -- intended for exclusive use in the GNAT run-time library.
12654 if Arg_Count
= 1 then
12655 Check_Arg_Is_Local_Name
(Arg1
);
12656 E_Id
:= Get_Pragma_Arg
(Arg1
);
12658 if Etype
(E_Id
) = Any_Type
then
12662 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12663 Record_Rep_Item
(Entity
(E_Id
), N
);
12666 Check_Arg_Count
(0);
12668 -- For Ada_2005 we unconditionally enforce the documented
12669 -- configuration pragma placement, since we do not want to
12670 -- tolerate mixed modes in a unit involving Ada 2005. That
12671 -- would cause real difficulties for those cases where there
12672 -- are incompatibilities between Ada 95 and Ada 2005.
12674 Check_Valid_Configuration_Pragma
;
12676 -- Now set appropriate Ada mode
12678 if Latest_Ada_Only
then
12679 Error_Pragma
("??pragma% ignored");
12681 Ada_Version
:= Ada_2005
;
12682 Ada_Version_Explicit
:= Ada_2005
;
12683 Ada_Version_Pragma
:= N
;
12688 ---------------------
12689 -- Ada_12/Ada_2012 --
12690 ---------------------
12693 -- pragma Ada_12 (LOCAL_NAME);
12695 -- pragma Ada_2012;
12696 -- pragma Ada_2012 (LOCAL_NAME):
12698 -- Note: these pragmas also have some specific processing in Par.Prag
12699 -- because we want to set the Ada 2012 version mode during parsing.
12701 -- The one argument form is used for managing the transition from Ada
12702 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12703 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12704 -- mode will generate a warning. In addition, in any pre-Ada_2012
12705 -- mode, a preference rule is established which does not choose
12706 -- such an entity unless it is unambiguously specified. This avoids
12707 -- extra subprograms marked this way from generating ambiguities in
12708 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12709 -- intended for exclusive use in the GNAT run-time library.
12720 if Arg_Count
= 1 then
12721 Check_Arg_Is_Local_Name
(Arg1
);
12722 E_Id
:= Get_Pragma_Arg
(Arg1
);
12724 if Etype
(E_Id
) = Any_Type
then
12728 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12729 Record_Rep_Item
(Entity
(E_Id
), N
);
12732 Check_Arg_Count
(0);
12734 -- For Ada_2012 we unconditionally enforce the documented
12735 -- configuration pragma placement, since we do not want to
12736 -- tolerate mixed modes in a unit involving Ada 2012. That
12737 -- would cause real difficulties for those cases where there
12738 -- are incompatibilities between Ada 95 and Ada 2012. We could
12739 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12741 Check_Valid_Configuration_Pragma
;
12743 -- Now set appropriate Ada mode
12745 Ada_Version
:= Ada_2012
;
12746 Ada_Version_Explicit
:= Ada_2012
;
12747 Ada_Version_Pragma
:= N
;
12755 -- pragma Ada_2022;
12756 -- pragma Ada_2022 (LOCAL_NAME):
12758 -- Note: this pragma also has some specific processing in Par.Prag
12759 -- because we want to set the Ada 2022 version mode during parsing.
12761 -- The one argument form is used for managing the transition from Ada
12762 -- 2012 to Ada 2022 in the run-time library. If an entity is marked
12763 -- as Ada_2022 only, then referencing the entity in any pre-Ada_2022
12764 -- mode will generate a warning;for calls to Ada_2022 only primitives
12765 -- that require overriding an error will be reported. In addition, in
12766 -- any pre-Ada_2022 mode, a preference rule is established which does
12767 -- not choose such an entity unless it is unambiguously specified.
12768 -- This avoids extra subprograms marked this way from generating
12769 -- ambiguities in otherwise legal pre-Ada 2022 programs. The one
12770 -- argument form is intended for exclusive use in the GNAT run-time
12773 when Pragma_Ada_2022
=>
12780 if Arg_Count
= 1 then
12781 Check_Arg_Is_Local_Name
(Arg1
);
12782 E_Id
:= Get_Pragma_Arg
(Arg1
);
12784 if Etype
(E_Id
) = Any_Type
then
12788 Set_Is_Ada_2022_Only
(Entity
(E_Id
));
12789 Record_Rep_Item
(Entity
(E_Id
), N
);
12792 Check_Arg_Count
(0);
12794 -- For Ada_2022 we unconditionally enforce the documented
12795 -- configuration pragma placement, since we do not want to
12796 -- tolerate mixed modes in a unit involving Ada 2022. That
12797 -- would cause real difficulties for those cases where there
12798 -- are incompatibilities between Ada 2012 and Ada 2022. We
12799 -- could allow mixing of Ada 2012 and Ada 2022 but it's not
12802 Check_Valid_Configuration_Pragma
;
12804 -- Now set appropriate Ada mode
12806 Ada_Version
:= Ada_2022
;
12807 Ada_Version_Explicit
:= Ada_2022
;
12808 Ada_Version_Pragma
:= N
;
12812 -------------------------------------
12813 -- Aggregate_Individually_Assign --
12814 -------------------------------------
12816 -- pragma Aggregate_Individually_Assign;
12818 when Pragma_Aggregate_Individually_Assign
=>
12820 Check_Arg_Count
(0);
12821 Check_Valid_Configuration_Pragma
;
12822 Aggregate_Individually_Assign
:= True;
12824 ----------------------
12825 -- All_Calls_Remote --
12826 ----------------------
12828 -- pragma All_Calls_Remote [(library_package_NAME)];
12830 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12831 Lib_Entity
: Entity_Id
;
12834 Check_Ada_83_Warning
;
12835 Check_Valid_Library_Unit_Pragma
;
12837 -- If N was rewritten as a null statement there is nothing more
12840 if Nkind
(N
) = N_Null_Statement
then
12844 Lib_Entity
:= Find_Lib_Unit_Name
;
12846 -- A pragma that applies to a Ghost entity becomes Ghost for the
12847 -- purposes of legality checks and removal of ignored Ghost code.
12849 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12851 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12853 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12854 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12855 Error_Pragma
("pragma% only apply to rci unit");
12857 -- Set flag for entity of the library unit
12860 Set_Has_All_Calls_Remote
(Lib_Entity
);
12863 end All_Calls_Remote
;
12865 ---------------------------
12866 -- Allow_Integer_Address --
12867 ---------------------------
12869 -- pragma Allow_Integer_Address;
12871 when Pragma_Allow_Integer_Address
=>
12873 Check_Valid_Configuration_Pragma
;
12874 Check_Arg_Count
(0);
12876 -- If Address is a private type, then set the flag to allow
12877 -- integer address values. If Address is not private, then this
12878 -- pragma has no purpose, so it is simply ignored. Not clear if
12879 -- there are any such targets now.
12881 if Opt
.Address_Is_Private
then
12882 Opt
.Allow_Integer_Address
:= True;
12890 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12891 -- ARG ::= NAME | EXPRESSION
12893 -- The first two arguments are by convention intended to refer to an
12894 -- external tool and a tool-specific function. These arguments are
12897 when Pragma_Annotate | Pragma_GNAT_Annotate
=> Annotate
: declare
12902 --------------------------
12903 -- Inferred_String_Type --
12904 --------------------------
12906 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
;
12907 -- Infer the type to use for a string literal or a concatentation
12908 -- of operands whose types can be inferred. For such expressions,
12909 -- returns the "narrowest" of the three predefined string types
12910 -- that can represent the characters occurring in the expression.
12911 -- For other expressions, returns Empty.
12913 function Preferred_String_Type
(Expr
: Node_Id
) return Entity_Id
is
12915 case Nkind
(Expr
) is
12916 when N_String_Literal
=>
12917 if Has_Wide_Wide_Character
(Expr
) then
12918 return Standard_Wide_Wide_String
;
12919 elsif Has_Wide_Character
(Expr
) then
12920 return Standard_Wide_String
;
12922 return Standard_String
;
12925 when N_Op_Concat
=>
12927 L_Type
: constant Entity_Id
12928 := Preferred_String_Type
(Left_Opnd
(Expr
));
12929 R_Type
: constant Entity_Id
12930 := Preferred_String_Type
(Right_Opnd
(Expr
));
12932 Type_Table
: constant array (1 .. 4) of Entity_Id
12934 Standard_Wide_Wide_String
,
12935 Standard_Wide_String
,
12938 for Idx
in Type_Table
'Range loop
12939 if (L_Type
= Type_Table
(Idx
)) or
12940 (R_Type
= Type_Table
(Idx
))
12942 return Type_Table
(Idx
);
12945 raise Program_Error
;
12951 end Preferred_String_Type
;
12954 Check_At_Least_N_Arguments
(1);
12956 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12958 -- Determine whether the last argument is "Entity => local_NAME"
12959 -- and if it is, perform the required semantic checks. Remove the
12960 -- argument from further processing.
12962 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12963 and then Chars
(Nam_Arg
) = Name_Entity
12965 Check_Arg_Is_Local_Name
(Nam_Arg
);
12966 Arg_Count
:= Arg_Count
- 1;
12968 -- A pragma that applies to a Ghost entity becomes Ghost for
12969 -- the purposes of legality checks and removal of ignored Ghost
12972 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12973 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12975 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12978 -- Not allowed in compiler units (bootstrap issues)
12980 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12983 -- Continue the processing with last argument removed for now
12985 Check_Arg_Is_Identifier
(Arg1
);
12986 Check_No_Identifiers
;
12989 -- The second parameter is optional, it is never analyzed
12994 -- Otherwise there is a second parameter
12997 -- The second parameter must be an identifier
12999 Check_Arg_Is_Identifier
(Arg2
);
13001 -- Process the remaining parameters (if any)
13003 Arg
:= Next
(Arg2
);
13004 while Present
(Arg
) loop
13005 Expr
:= Get_Pragma_Arg
(Arg
);
13008 if Is_Entity_Name
(Expr
) then
13011 -- For string literals and concatenations of string literals
13012 -- we assume Standard_String as the type, unless the string
13013 -- contains wide or wide_wide characters.
13015 elsif Present
(Preferred_String_Type
(Expr
)) then
13016 Resolve
(Expr
, Preferred_String_Type
(Expr
));
13018 elsif Is_Overloaded
(Expr
) then
13019 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13030 -------------------------------------------------
13031 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13032 -------------------------------------------------
13035 -- ( [Check => ] Boolean_EXPRESSION
13036 -- [, [Message =>] Static_String_EXPRESSION]);
13038 -- pragma Assert_And_Cut
13039 -- ( [Check => ] Boolean_EXPRESSION
13040 -- [, [Message =>] Static_String_EXPRESSION]);
13043 -- ( [Check => ] Boolean_EXPRESSION
13044 -- [, [Message =>] Static_String_EXPRESSION]);
13046 -- pragma Loop_Invariant
13047 -- ( [Check => ] Boolean_EXPRESSION
13048 -- [, [Message =>] Static_String_EXPRESSION]);
13051 | Pragma_Assert_And_Cut
13053 | Pragma_Loop_Invariant
13056 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13057 -- Determine whether expression Expr contains a Loop_Entry
13058 -- attribute reference.
13060 -------------------------
13061 -- Contains_Loop_Entry --
13062 -------------------------
13064 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13065 Has_Loop_Entry
: Boolean := False;
13067 function Process
(N
: Node_Id
) return Traverse_Result
;
13068 -- Process function for traversal to look for Loop_Entry
13074 function Process
(N
: Node_Id
) return Traverse_Result
is
13076 if Nkind
(N
) = N_Attribute_Reference
13077 and then Attribute_Name
(N
) = Name_Loop_Entry
13079 Has_Loop_Entry
:= True;
13086 procedure Traverse
is new Traverse_Proc
(Process
);
13088 -- Start of processing for Contains_Loop_Entry
13092 return Has_Loop_Entry
;
13093 end Contains_Loop_Entry
;
13098 New_Args
: List_Id
;
13100 -- Start of processing for Assert
13103 -- Assert is an Ada 2005 RM-defined pragma
13105 if Prag_Id
= Pragma_Assert
then
13108 -- The remaining ones are GNAT pragmas
13114 Check_At_Least_N_Arguments
(1);
13115 Check_At_Most_N_Arguments
(2);
13116 Check_Arg_Order
((Name_Check
, Name_Message
));
13117 Check_Optional_Identifier
(Arg1
, Name_Check
);
13118 Expr
:= Get_Pragma_Arg
(Arg1
);
13120 -- Special processing for Loop_Invariant, Loop_Variant or for
13121 -- other cases where a Loop_Entry attribute is present. If the
13122 -- assertion pragma contains attribute Loop_Entry, ensure that
13123 -- the related pragma is within a loop.
13125 if Prag_Id
= Pragma_Loop_Invariant
13126 or else Prag_Id
= Pragma_Loop_Variant
13127 or else Contains_Loop_Entry
(Expr
)
13129 Check_Loop_Pragma_Placement
;
13131 -- Perform preanalysis to deal with embedded Loop_Entry
13134 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13137 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13138 -- a corresponding Check pragma:
13140 -- pragma Check (name, condition [, msg]);
13142 -- Where name is the identifier matching the pragma name. So
13143 -- rewrite pragma in this manner, transfer the message argument
13144 -- if present, and analyze the result
13146 -- Note: When dealing with a semantically analyzed tree, the
13147 -- information that a Check node N corresponds to a source Assert,
13148 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13149 -- pragma kind of Original_Node(N).
13151 New_Args
:= New_List
(
13152 Make_Pragma_Argument_Association
(Loc
,
13153 Expression
=> Make_Identifier
(Loc
, Pname
)),
13154 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13155 Expression
=> Expr
));
13157 if Arg_Count
> 1 then
13158 Check_Optional_Identifier
(Arg2
, Name_Message
);
13160 -- Provide semantic annotations for optional argument, for
13161 -- ASIS use, before rewriting.
13162 -- Is this still needed???
13164 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13165 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13168 -- Rewrite as Check pragma
13172 Chars
=> Name_Check
,
13173 Pragma_Argument_Associations
=> New_Args
));
13178 ----------------------
13179 -- Assertion_Policy --
13180 ----------------------
13182 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13184 -- The following form is Ada 2012 only, but we allow it in all modes
13186 -- Pragma Assertion_Policy (
13187 -- ASSERTION_KIND => POLICY_IDENTIFIER
13188 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13190 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13192 -- RM_ASSERTION_KIND ::= Assert |
13193 -- Static_Predicate |
13194 -- Dynamic_Predicate |
13199 -- Type_Invariant |
13200 -- Type_Invariant'Class |
13201 -- Default_Initial_Condition
13203 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13205 -- Contract_Cases |
13208 -- Initial_Condition |
13209 -- Loop_Invariant |
13215 -- Statement_Assertions |
13216 -- Subprogram_Variant
13218 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13219 -- ID_ASSERTION_KIND list contains implementation-defined additions
13220 -- recognized by GNAT. The effect is to control the behavior of
13221 -- identically named aspects and pragmas, depending on the specified
13222 -- policy identifier:
13224 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13226 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13227 -- implementation-defined addition that results in totally ignoring
13228 -- the corresponding assertion. If Disable is specified, then the
13229 -- argument of the assertion is not even analyzed. This is useful
13230 -- when the aspect/pragma argument references entities in a with'ed
13231 -- package that is replaced by a dummy package in the final build.
13233 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13234 -- and Type_Invariant'Class were recognized by the parser and
13235 -- transformed into references to the special internal identifiers
13236 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13237 -- processing is required here.
13239 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13240 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13241 -- Converts the assertion policy 'Suppressible' to either Check or
13242 -- Ignore based on whether checks are suppressed via -gnatp.
13244 --------------------------
13245 -- Resolve_Suppressible --
13246 --------------------------
13248 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13249 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13253 -- Transform policy argument Suppressible into either Ignore or
13254 -- Check depending on whether checks are enabled or suppressed.
13256 if Chars
(Arg
) = Name_Suppressible
then
13257 if Suppress_Checks
then
13258 Nam
:= Name_Ignore
;
13263 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13265 end Resolve_Suppressible
;
13277 -- This can always appear as a configuration pragma
13279 if Is_Configuration_Pragma
then
13282 -- It can also appear in a declarative part or package spec in Ada
13283 -- 2012 mode. We allow this in other modes, but in that case we
13284 -- consider that we have an Ada 2012 pragma on our hands.
13287 Check_Is_In_Decl_Part_Or_Package_Spec
;
13291 -- One argument case with no identifier (first form above)
13294 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13295 or else Chars
(Arg1
) = No_Name
)
13297 Check_Arg_Is_One_Of
(Arg1
,
13298 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13300 Resolve_Suppressible
(Arg1
);
13302 -- Treat one argument Assertion_Policy as equivalent to:
13304 -- pragma Check_Policy (Assertion, policy)
13306 -- So rewrite pragma in that manner and link on to the chain
13307 -- of Check_Policy pragmas, marking the pragma as analyzed.
13309 Policy
:= Get_Pragma_Arg
(Arg1
);
13313 Chars
=> Name_Check_Policy
,
13314 Pragma_Argument_Associations
=> New_List
(
13315 Make_Pragma_Argument_Association
(Loc
,
13316 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13318 Make_Pragma_Argument_Association
(Loc
,
13320 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13323 -- Here if we have two or more arguments
13326 Check_At_Least_N_Arguments
(1);
13329 -- Loop through arguments
13332 while Present
(Arg
) loop
13333 LocP
:= Sloc
(Arg
);
13335 -- Kind must be specified
13337 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13338 or else Chars
(Arg
) = No_Name
13341 ("missing assertion kind for pragma%", Arg
);
13344 -- Check Kind and Policy have allowed forms
13346 Kind
:= Chars
(Arg
);
13347 Policy
:= Get_Pragma_Arg
(Arg
);
13349 if not Is_Valid_Assertion_Kind
(Kind
) then
13351 ("invalid assertion kind for pragma%", Arg
);
13354 Check_Arg_Is_One_Of
(Arg
,
13355 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13357 Resolve_Suppressible
(Arg
);
13359 if Kind
= Name_Ghost
then
13361 -- The Ghost policy must be either Check or Ignore
13362 -- (SPARK RM 6.9(6)).
13364 if Chars
(Policy
) not in Name_Check | Name_Ignore
then
13366 ("argument of pragma % Ghost must be Check or "
13367 & "Ignore", Policy
);
13370 -- Pragma Assertion_Policy specifying a Ghost policy
13371 -- cannot occur within a Ghost subprogram or package
13372 -- (SPARK RM 6.9(14)).
13374 if Ghost_Mode
> None
then
13376 ("pragma % cannot appear within ghost subprogram or "
13381 -- Rewrite the Assertion_Policy pragma as a series of
13382 -- Check_Policy pragmas of the form:
13384 -- Check_Policy (Kind, Policy);
13386 -- Note: the insertion of the pragmas cannot be done with
13387 -- Insert_Action because in the configuration case, there
13388 -- are no scopes on the scope stack and the mechanism will
13391 Insert_Before_And_Analyze
(N
,
13393 Chars
=> Name_Check_Policy
,
13394 Pragma_Argument_Associations
=> New_List
(
13395 Make_Pragma_Argument_Association
(LocP
,
13396 Expression
=> Make_Identifier
(LocP
, Kind
)),
13397 Make_Pragma_Argument_Association
(LocP
,
13398 Expression
=> Policy
))));
13403 -- Rewrite the Assertion_Policy pragma as null since we have
13404 -- now inserted all the equivalent Check pragmas.
13406 Rewrite
(N
, Make_Null_Statement
(Loc
));
13409 end Assertion_Policy
;
13411 ------------------------------
13412 -- Assume_No_Invalid_Values --
13413 ------------------------------
13415 -- pragma Assume_No_Invalid_Values (On | Off);
13417 when Pragma_Assume_No_Invalid_Values
=>
13419 Check_Valid_Configuration_Pragma
;
13420 Check_Arg_Count
(1);
13421 Check_No_Identifiers
;
13422 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13424 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13425 Assume_No_Invalid_Values
:= True;
13427 Assume_No_Invalid_Values
:= False;
13430 --------------------------
13431 -- Attribute_Definition --
13432 --------------------------
13434 -- pragma Attribute_Definition
13435 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13436 -- [Entity =>] LOCAL_NAME,
13437 -- [Expression =>] EXPRESSION | NAME);
13439 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13440 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13445 Check_Arg_Count
(3);
13446 Check_Optional_Identifier
(Arg1
, "attribute");
13447 Check_Optional_Identifier
(Arg2
, "entity");
13448 Check_Optional_Identifier
(Arg3
, "expression");
13450 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13451 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13455 Check_Arg_Is_Local_Name
(Arg2
);
13457 -- If the attribute is not recognized, then issue a warning (not
13458 -- an error), and ignore the pragma.
13460 Aname
:= Chars
(Attribute_Designator
);
13462 if not Is_Attribute_Name
(Aname
) then
13463 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13467 -- Otherwise, rewrite the pragma as an attribute definition clause
13470 Make_Attribute_Definition_Clause
(Loc
,
13471 Name
=> Get_Pragma_Arg
(Arg2
),
13473 Expression
=> Get_Pragma_Arg
(Arg3
)));
13475 end Attribute_Definition
;
13477 ------------------------------------------------------------------
13478 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13480 ------------------------------------------------------------------
13482 -- pragma Async_Readers [ (boolean_EXPRESSION) ];
13483 -- pragma Async_Writers [ (boolean_EXPRESSION) ];
13484 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13485 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13486 -- pragma No_Caching [ (boolean_EXPRESSION) ];
13488 when Pragma_Async_Readers
13489 | Pragma_Async_Writers
13490 | Pragma_Effective_Reads
13491 | Pragma_Effective_Writes
13492 | Pragma_No_Caching
13494 Async_Effective
: declare
13495 Obj_Or_Type_Decl
: Node_Id
;
13496 Obj_Or_Type_Id
: Entity_Id
;
13499 Check_No_Identifiers
;
13500 Check_At_Most_N_Arguments
(1);
13502 Obj_Or_Type_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13504 -- Pragma must apply to a object declaration or to a type
13505 -- declaration (only the former in the No_Caching case).
13506 -- Original_Node is necessary to account for untagged derived
13507 -- types that are rewritten as subtypes of their
13508 -- respective root types.
13510 if Nkind
(Obj_Or_Type_Decl
) /= N_Object_Declaration
then
13511 if Prag_Id
= Pragma_No_Caching
13512 or else Nkind
(Original_Node
(Obj_Or_Type_Decl
)) not in
13513 N_Full_Type_Declaration |
13514 N_Private_Type_Declaration |
13515 N_Formal_Type_Declaration |
13516 N_Task_Type_Declaration |
13517 N_Protected_Type_Declaration
13524 Obj_Or_Type_Id
:= Defining_Entity
(Obj_Or_Type_Decl
);
13526 -- Perform minimal verification to ensure that the argument is at
13527 -- least an object or a type. Subsequent finer grained checks will
13528 -- be done at the end of the declarative region that contains the
13531 if Ekind
(Obj_Or_Type_Id
) in E_Constant | E_Variable
13532 or else Is_Type
(Obj_Or_Type_Id
)
13535 -- In the case of a type, pragma is a type-related
13536 -- representation item and so requires checks common to
13537 -- all type-related representation items.
13539 if Is_Type
(Obj_Or_Type_Id
)
13540 and then Rep_Item_Too_Late
(Obj_Or_Type_Id
, N
)
13545 -- A pragma that applies to a Ghost entity becomes Ghost for
13546 -- the purposes of legality checks and removal of ignored Ghost
13549 Mark_Ghost_Pragma
(N
, Obj_Or_Type_Id
);
13551 -- Chain the pragma on the contract for further processing by
13552 -- Analyze_External_Property_In_Decl_Part.
13554 Add_Contract_Item
(N
, Obj_Or_Type_Id
);
13556 -- Analyze the Boolean expression (if any)
13558 if Present
(Arg1
) then
13559 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13562 -- Otherwise the external property applies to a constant
13566 ("pragma % must apply to a volatile type or object");
13568 end Async_Effective
;
13574 -- pragma Asynchronous (LOCAL_NAME);
13576 when Pragma_Asynchronous
=> Asynchronous
: declare
13579 Formal
: Entity_Id
;
13584 procedure Process_Async_Pragma
;
13585 -- Common processing for procedure and access-to-procedure case
13587 --------------------------
13588 -- Process_Async_Pragma --
13589 --------------------------
13591 procedure Process_Async_Pragma
is
13594 Set_Is_Asynchronous
(Nm
);
13598 -- The formals should be of mode IN (RM E.4.1(6))
13601 while Present
(S
) loop
13602 Formal
:= Defining_Identifier
(S
);
13604 if Nkind
(Formal
) = N_Defining_Identifier
13605 and then Ekind
(Formal
) /= E_In_Parameter
13608 ("pragma% procedure can only have IN parameter",
13615 Set_Is_Asynchronous
(Nm
);
13616 end Process_Async_Pragma
;
13618 -- Start of processing for pragma Asynchronous
13621 Check_Ada_83_Warning
;
13622 Check_No_Identifiers
;
13623 Check_Arg_Count
(1);
13624 Check_Arg_Is_Local_Name
(Arg1
);
13626 if Debug_Flag_U
then
13630 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13631 Analyze
(Get_Pragma_Arg
(Arg1
));
13632 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
13634 -- A pragma that applies to a Ghost entity becomes Ghost for the
13635 -- purposes of legality checks and removal of ignored Ghost code.
13637 Mark_Ghost_Pragma
(N
, Nm
);
13639 if not Is_Remote_Call_Interface
(C_Ent
)
13640 and then not Is_Remote_Types
(C_Ent
)
13642 -- This pragma should only appear in an RCI or Remote Types
13643 -- unit (RM E.4.1(4)).
13646 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13649 if Ekind
(Nm
) = E_Procedure
13650 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13652 if not Is_Remote_Call_Interface
(Nm
) then
13654 ("pragma% cannot be applied on non-remote procedure",
13658 L
:= Parameter_Specifications
(Parent
(Nm
));
13659 Process_Async_Pragma
;
13662 elsif Ekind
(Nm
) = E_Function
then
13664 ("pragma% cannot be applied to function", Arg1
);
13666 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13667 if Is_Record_Type
(Nm
) then
13669 -- A record type that is the Equivalent_Type for a remote
13670 -- access-to-subprogram type.
13672 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13675 -- A non-expanded RAS type (distribution is not enabled)
13677 Decl
:= Declaration_Node
(Nm
);
13680 if Nkind
(Decl
) = N_Full_Type_Declaration
13681 and then Nkind
(Type_Definition
(Decl
)) =
13682 N_Access_Procedure_Definition
13684 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13685 Process_Async_Pragma
;
13687 if Is_Asynchronous
(Nm
)
13688 and then Expander_Active
13689 and then Get_PCS_Name
/= Name_No_DSA
13691 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13696 ("pragma% cannot reference access-to-function type",
13700 -- Only other possibility is access-to-class-wide type
13702 elsif Is_Access_Type
(Nm
)
13703 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13705 Check_First_Subtype
(Arg1
);
13706 Set_Is_Asynchronous
(Nm
);
13707 if Expander_Active
then
13708 RACW_Type_Is_Asynchronous
(Nm
);
13712 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13720 -- pragma Atomic (LOCAL_NAME);
13722 when Pragma_Atomic
=>
13723 Process_Atomic_Independent_Shared_Volatile
;
13725 -----------------------
13726 -- Atomic_Components --
13727 -----------------------
13729 -- pragma Atomic_Components (array_LOCAL_NAME);
13731 -- This processing is shared by Volatile_Components
13733 when Pragma_Atomic_Components
13734 | Pragma_Volatile_Components
13736 Atomic_Components
: declare
13742 Check_Ada_83_Warning
;
13743 Check_No_Identifiers
;
13744 Check_Arg_Count
(1);
13745 Check_Arg_Is_Local_Name
(Arg1
);
13746 E_Id
:= Get_Pragma_Arg
(Arg1
);
13748 if Etype
(E_Id
) = Any_Type
then
13752 E
:= Entity
(E_Id
);
13754 -- A pragma that applies to a Ghost entity becomes Ghost for the
13755 -- purposes of legality checks and removal of ignored Ghost code.
13757 Mark_Ghost_Pragma
(N
, E
);
13758 Check_Duplicate_Pragma
(E
);
13760 if Rep_Item_Too_Early
(E
, N
)
13762 Rep_Item_Too_Late
(E
, N
)
13767 D
:= Declaration_Node
(E
);
13769 if (Nkind
(D
) = N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13771 (Nkind
(D
) = N_Object_Declaration
13772 and then Ekind
(E
) in E_Constant | E_Variable
13773 and then Nkind
(Object_Definition
(D
)) =
13774 N_Constrained_Array_Definition
)
13776 (Ada_Version
>= Ada_2022
13777 and then Nkind
(D
) = N_Formal_Type_Declaration
)
13779 -- The flag is set on the base type, or on the object
13781 if Nkind
(D
) = N_Full_Type_Declaration
then
13782 E
:= Base_Type
(E
);
13785 -- Atomic implies both Independent and Volatile
13787 if Prag_Id
= Pragma_Atomic_Components
then
13788 Set_Has_Atomic_Components
(E
);
13789 Set_Has_Independent_Components
(E
);
13792 Set_Has_Volatile_Components
(E
);
13795 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13797 end Atomic_Components
;
13799 --------------------
13800 -- Attach_Handler --
13801 --------------------
13803 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13805 when Pragma_Attach_Handler
=>
13806 Check_Ada_83_Warning
;
13807 Check_No_Identifiers
;
13808 Check_Arg_Count
(2);
13810 if No_Run_Time_Mode
then
13811 Error_Msg_CRT
("Attach_Handler pragma", N
);
13813 Check_Interrupt_Or_Attach_Handler
;
13815 -- The expression that designates the attribute may depend on a
13816 -- discriminant, and is therefore a per-object expression, to
13817 -- be expanded in the init proc. If expansion is enabled, then
13818 -- perform semantic checks on a copy only.
13823 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13826 -- In Relaxed_RM_Semantics mode, we allow any static
13827 -- integer value, for compatibility with other compilers.
13829 if Relaxed_RM_Semantics
13830 and then Nkind
(Parg2
) = N_Integer_Literal
13832 Typ
:= Standard_Integer
;
13834 Typ
:= RTE
(RE_Interrupt_ID
);
13837 if Expander_Active
then
13838 Temp
:= New_Copy_Tree
(Parg2
);
13839 Set_Parent
(Temp
, N
);
13840 Preanalyze_And_Resolve
(Temp
, Typ
);
13843 Resolve
(Parg2
, Typ
);
13847 Process_Interrupt_Or_Attach_Handler
;
13850 --------------------
13851 -- C_Pass_By_Copy --
13852 --------------------
13854 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13856 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13862 Check_Valid_Configuration_Pragma
;
13863 Check_Arg_Count
(1);
13864 Check_Optional_Identifier
(Arg1
, "max_size");
13866 Arg
:= Get_Pragma_Arg
(Arg1
);
13867 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13869 Val
:= Expr_Value
(Arg
);
13873 ("maximum size for pragma% must be positive", Arg1
);
13875 elsif UI_Is_In_Int_Range
(Val
) then
13876 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13878 -- If a giant value is given, Int'Last will do well enough.
13879 -- If sometime someone complains that a record larger than
13880 -- two gigabytes is not copied, we will worry about it then.
13883 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13885 end C_Pass_By_Copy
;
13891 -- pragma Check ([Name =>] CHECK_KIND,
13892 -- [Check =>] Boolean_EXPRESSION
13893 -- [,[Message =>] String_EXPRESSION]);
13895 -- CHECK_KIND ::= IDENTIFIER |
13898 -- Invariant'Class |
13899 -- Type_Invariant'Class
13901 -- The identifiers Assertions and Statement_Assertions are not
13902 -- allowed, since they have special meaning for Check_Policy.
13904 -- WARNING: The code below manages Ghost regions. Return statements
13905 -- must be replaced by gotos which jump to the end of the code and
13906 -- restore the Ghost mode.
13908 when Pragma_Check
=> Check
: declare
13909 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13910 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13911 -- Save the Ghost-related attributes to restore on exit
13917 pragma Warnings
(Off
, Str
);
13920 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13921 -- the mode now to ensure that any nodes generated during analysis
13922 -- and expansion are marked as Ghost.
13924 Set_Ghost_Mode
(N
);
13927 Check_At_Least_N_Arguments
(2);
13928 Check_At_Most_N_Arguments
(3);
13929 Check_Optional_Identifier
(Arg1
, Name_Name
);
13930 Check_Optional_Identifier
(Arg2
, Name_Check
);
13932 if Arg_Count
= 3 then
13933 Check_Optional_Identifier
(Arg3
, Name_Message
);
13934 Str
:= Get_Pragma_Arg
(Arg3
);
13937 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13938 Check_Arg_Is_Identifier
(Arg1
);
13939 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13941 -- Check forbidden name Assertions or Statement_Assertions
13944 when Name_Assertions
=>
13946 ("""Assertions"" is not allowed as a check kind for "
13947 & "pragma%", Arg1
);
13949 when Name_Statement_Assertions
=>
13951 ("""Statement_Assertions"" is not allowed as a check kind "
13952 & "for pragma%", Arg1
);
13958 -- Check applicable policy. We skip this if Checked/Ignored status
13959 -- is already set (e.g. in the case of a pragma from an aspect).
13961 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13964 -- For a non-source pragma that is a rewriting of another pragma,
13965 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13967 elsif Is_Rewrite_Substitution
(N
)
13968 and then Nkind
(Original_Node
(N
)) = N_Pragma
13970 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13971 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13973 -- Otherwise query the applicable policy at this point
13976 case Check_Kind
(Cname
) is
13977 when Name_Ignore
=>
13978 Set_Is_Ignored
(N
, True);
13979 Set_Is_Checked
(N
, False);
13982 Set_Is_Ignored
(N
, False);
13983 Set_Is_Checked
(N
, True);
13985 -- For disable, rewrite pragma as null statement and skip
13986 -- rest of the analysis of the pragma.
13988 when Name_Disable
=>
13989 Rewrite
(N
, Make_Null_Statement
(Loc
));
13993 -- No other possibilities
13996 raise Program_Error
;
14000 -- If check kind was not Disable, then continue pragma analysis
14002 Expr
:= Get_Pragma_Arg
(Arg2
);
14004 -- Mark the pragma (or, if rewritten from an aspect, the original
14005 -- aspect) as enabled. Nothing to do for an internally generated
14006 -- check for a dynamic predicate.
14009 and then not Split_PPC
(N
)
14010 and then Cname
/= Name_Dynamic_Predicate
14012 Set_SCO_Pragma_Enabled
(Loc
);
14015 -- Deal with analyzing the string argument. If checks are not
14016 -- on we don't want any expansion (since such expansion would
14017 -- not get properly deleted) but we do want to analyze (to get
14018 -- proper references). The Preanalyze_And_Resolve routine does
14019 -- just what we want. Ditto if pragma is active, because it will
14020 -- be rewritten as an if-statement whose analysis will complete
14021 -- analysis and expansion of the string message. This makes a
14022 -- difference in the unusual case where the expression for the
14023 -- string may have a side effect, such as raising an exception.
14024 -- This is mandated by RM 11.4.2, which specifies that the string
14025 -- expression is only evaluated if the check fails and
14026 -- Assertion_Error is to be raised.
14028 if Arg_Count
= 3 then
14029 Preanalyze_And_Resolve
(Str
, Standard_String
);
14032 -- Now you might think we could just do the same with the Boolean
14033 -- expression if checks are off (and expansion is on) and then
14034 -- rewrite the check as a null statement. This would work but we
14035 -- would lose the useful warnings about an assertion being bound
14036 -- to fail even if assertions are turned off.
14038 -- So instead we wrap the boolean expression in an if statement
14039 -- that looks like:
14041 -- if False and then condition then
14045 -- The reason we do this rewriting during semantic analysis rather
14046 -- than as part of normal expansion is that we cannot analyze and
14047 -- expand the code for the boolean expression directly, or it may
14048 -- cause insertion of actions that would escape the attempt to
14049 -- suppress the check code.
14051 -- Note that the Sloc for the if statement corresponds to the
14052 -- argument condition, not the pragma itself. The reason for
14053 -- this is that we may generate a warning if the condition is
14054 -- False at compile time, and we do not want to delete this
14055 -- warning when we delete the if statement.
14057 if Expander_Active
and Is_Ignored
(N
) then
14058 Eloc
:= Sloc
(Expr
);
14061 Make_If_Statement
(Eloc
,
14063 Make_And_Then
(Eloc
,
14064 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14065 Right_Opnd
=> Expr
),
14066 Then_Statements
=> New_List
(
14067 Make_Null_Statement
(Eloc
))));
14069 -- Now go ahead and analyze the if statement
14071 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14073 -- One rather special treatment. If we are now in Eliminated
14074 -- overflow mode, then suppress overflow checking since we do
14075 -- not want to drag in the bignum stuff if we are in Ignore
14076 -- mode anyway. This is particularly important if we are using
14077 -- a configurable run time that does not support bignum ops.
14079 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14081 Svo
: constant Boolean :=
14082 Scope_Suppress
.Suppress
(Overflow_Check
);
14084 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14085 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14087 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14088 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14091 -- Not that special case
14097 -- All done with this check
14099 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14101 -- Check is active or expansion not active. In these cases we can
14102 -- just go ahead and analyze the boolean with no worries.
14105 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14106 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14107 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14110 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14113 --------------------------
14114 -- Check_Float_Overflow --
14115 --------------------------
14117 -- pragma Check_Float_Overflow;
14119 when Pragma_Check_Float_Overflow
=>
14121 Check_Valid_Configuration_Pragma
;
14122 Check_Arg_Count
(0);
14123 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14129 -- pragma Check_Name (check_IDENTIFIER);
14131 when Pragma_Check_Name
=>
14133 Check_No_Identifiers
;
14134 Check_Valid_Configuration_Pragma
;
14135 Check_Arg_Count
(1);
14136 Check_Arg_Is_Identifier
(Arg1
);
14139 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14142 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14143 if Check_Names
.Table
(J
) = Nam
then
14148 Check_Names
.Append
(Nam
);
14155 -- This is the old style syntax, which is still allowed in all modes:
14157 -- pragma Check_Policy ([Name =>] CHECK_KIND
14158 -- [Policy =>] POLICY_IDENTIFIER);
14160 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14162 -- CHECK_KIND ::= IDENTIFIER |
14165 -- Type_Invariant'Class |
14168 -- This is the new style syntax, compatible with Assertion_Policy
14169 -- and also allowed in all modes.
14171 -- Pragma Check_Policy (
14172 -- CHECK_KIND => POLICY_IDENTIFIER
14173 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14175 -- Note: the identifiers Name and Policy are not allowed as
14176 -- Check_Kind values. This avoids ambiguities between the old and
14177 -- new form syntax.
14179 when Pragma_Check_Policy
=> Check_Policy
: declare
14184 Check_At_Least_N_Arguments
(1);
14186 -- A Check_Policy pragma can appear either as a configuration
14187 -- pragma, or in a declarative part or a package spec (see RM
14188 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14189 -- followed for Check_Policy).
14191 if not Is_Configuration_Pragma
then
14192 Check_Is_In_Decl_Part_Or_Package_Spec
;
14195 -- Figure out if we have the old or new syntax. We have the
14196 -- old syntax if the first argument has no identifier, or the
14197 -- identifier is Name.
14199 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14200 or else Chars
(Arg1
) in No_Name | Name_Name
14204 Check_Arg_Count
(2);
14205 Check_Optional_Identifier
(Arg1
, Name_Name
);
14206 Kind
:= Get_Pragma_Arg
(Arg1
);
14207 Rewrite_Assertion_Kind
(Kind
,
14208 From_Policy
=> Comes_From_Source
(N
));
14209 Check_Arg_Is_Identifier
(Arg1
);
14211 -- Check forbidden check kind
14213 if Chars
(Kind
) in Name_Name | Name_Policy
then
14214 Error_Msg_Name_2
:= Chars
(Kind
);
14216 ("pragma% does not allow% as check name", Arg1
);
14221 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14222 Check_Arg_Is_One_Of
14224 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14226 -- And chain pragma on the Check_Policy_List for search
14228 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14229 Opt
.Check_Policy_List
:= N
;
14231 -- For the new syntax, what we do is to convert each argument to
14232 -- an old syntax equivalent. We do that because we want to chain
14233 -- old style Check_Policy pragmas for the search (we don't want
14234 -- to have to deal with multiple arguments in the search).
14245 while Present
(Arg
) loop
14246 LocP
:= Sloc
(Arg
);
14247 Argx
:= Get_Pragma_Arg
(Arg
);
14249 -- Kind must be specified
14251 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14252 or else Chars
(Arg
) = No_Name
14255 ("missing assertion kind for pragma%", Arg
);
14258 -- Construct equivalent old form syntax Check_Policy
14259 -- pragma and insert it to get remaining checks.
14263 Chars
=> Name_Check_Policy
,
14264 Pragma_Argument_Associations
=> New_List
(
14265 Make_Pragma_Argument_Association
(LocP
,
14267 Make_Identifier
(LocP
, Chars
(Arg
))),
14268 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14269 Expression
=> Argx
)));
14273 -- For a configuration pragma, insert old form in
14274 -- the corresponding file.
14276 if Is_Configuration_Pragma
then
14277 Insert_After
(N
, New_P
);
14281 Insert_Action
(N
, New_P
);
14285 -- Rewrite original Check_Policy pragma to null, since we
14286 -- have converted it into a series of old syntax pragmas.
14288 Rewrite
(N
, Make_Null_Statement
(Loc
));
14298 -- pragma Comment (static_string_EXPRESSION)
14300 -- Processing for pragma Comment shares the circuitry for pragma
14301 -- Ident. The only differences are that Ident enforces a limit of 31
14302 -- characters on its argument, and also enforces limitations on
14303 -- placement for DEC compatibility. Pragma Comment shares neither of
14304 -- these restrictions.
14306 -------------------
14307 -- Common_Object --
14308 -------------------
14310 -- pragma Common_Object (
14311 -- [Internal =>] LOCAL_NAME
14312 -- [, [External =>] EXTERNAL_SYMBOL]
14313 -- [, [Size =>] EXTERNAL_SYMBOL]);
14315 -- Processing for this pragma is shared with Psect_Object
14317 ----------------------------------------------
14318 -- Compile_Time_Error, Compile_Time_Warning --
14319 ----------------------------------------------
14321 -- pragma Compile_Time_Error
14322 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14324 -- pragma Compile_Time_Warning
14325 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14327 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning
=>
14330 -- These pragmas rely on the context. In adc files they raise
14331 -- Constraint_Error. Ban them from use as configuration pragmas
14332 -- even in cases where such a use could work.
14334 if Is_Configuration_Pragma
then
14336 ("pragma% is not allowed as a configuration pragma");
14339 Process_Compile_Time_Warning_Or_Error
;
14341 ---------------------------
14342 -- Compiler_Unit_Warning --
14343 ---------------------------
14345 -- pragma Compiler_Unit_Warning;
14349 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14350 -- errors not warnings. This means that we had introduced a big extra
14351 -- inertia to compiler changes, since even if we implemented a new
14352 -- feature, and even if all versions to be used for bootstrapping
14353 -- implemented this new feature, we could not use it, since old
14354 -- compilers would give errors for using this feature in units
14355 -- having Compiler_Unit pragmas.
14357 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14358 -- problem. We no longer have any units mentioning Compiler_Unit,
14359 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14360 -- and thus generates a warning which can be ignored. So that deals
14361 -- with the problem of old compilers not implementing the newer form
14364 -- Newer compilers recognize the new pragma, but generate warning
14365 -- messages instead of errors, which again can be ignored in the
14366 -- case of an old compiler which implements a wanted new feature
14367 -- but at the time felt like warning about it for older compilers.
14369 -- We retain Compiler_Unit so that new compilers can be used to build
14370 -- older run-times that use this pragma. That's an unusual case, but
14371 -- it's easy enough to handle, so why not?
14373 when Pragma_Compiler_Unit
14374 | Pragma_Compiler_Unit_Warning
14377 Check_Arg_Count
(0);
14379 -- Only recognized in main unit
14381 if Current_Sem_Unit
= Main_Unit
then
14382 Compiler_Unit
:= True;
14385 -----------------------------
14386 -- Complete_Representation --
14387 -----------------------------
14389 -- pragma Complete_Representation;
14391 when Pragma_Complete_Representation
=>
14393 Check_Arg_Count
(0);
14395 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14397 ("pragma & must appear within record representation clause");
14400 ----------------------------
14401 -- Complex_Representation --
14402 ----------------------------
14404 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14406 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14413 Check_Arg_Count
(1);
14414 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14415 Check_Arg_Is_Local_Name
(Arg1
);
14416 E_Id
:= Get_Pragma_Arg
(Arg1
);
14418 if Etype
(E_Id
) = Any_Type
then
14422 E
:= Entity
(E_Id
);
14424 if not Is_Record_Type
(E
) then
14426 ("argument for pragma% must be record type", Arg1
);
14429 Ent
:= First_Entity
(E
);
14432 or else No
(Next_Entity
(Ent
))
14433 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14434 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14435 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14438 ("record for pragma% must have two fields of the same "
14439 & "floating-point type", Arg1
);
14442 Set_Has_Complex_Representation
(Base_Type
(E
));
14444 -- We need to treat the type has having a non-standard
14445 -- representation, for back-end purposes, even though in
14446 -- general a complex will have the default representation
14447 -- of a record with two real components.
14449 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14451 end Complex_Representation
;
14453 -------------------------
14454 -- Component_Alignment --
14455 -------------------------
14457 -- pragma Component_Alignment (
14458 -- [Form =>] ALIGNMENT_CHOICE
14459 -- [, [Name =>] type_LOCAL_NAME]);
14461 -- ALIGNMENT_CHOICE ::=
14463 -- | Component_Size_4
14467 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14468 Args
: Args_List
(1 .. 2);
14469 Names
: constant Name_List
(1 .. 2) := (
14473 Form
: Node_Id
renames Args
(1);
14474 Name
: Node_Id
renames Args
(2);
14476 Atype
: Component_Alignment_Kind
;
14481 Gather_Associations
(Names
, Args
);
14484 Error_Pragma
("missing Form argument for pragma%");
14487 Check_Arg_Is_Identifier
(Form
);
14489 -- Get proper alignment, note that Default = Component_Size on all
14490 -- machines we have so far, and we want to set this value rather
14491 -- than the default value to indicate that it has been explicitly
14492 -- set (and thus will not get overridden by the default component
14493 -- alignment for the current scope)
14495 if Chars
(Form
) = Name_Component_Size
then
14496 Atype
:= Calign_Component_Size
;
14498 elsif Chars
(Form
) = Name_Component_Size_4
then
14499 Atype
:= Calign_Component_Size_4
;
14501 elsif Chars
(Form
) = Name_Default
then
14502 Atype
:= Calign_Component_Size
;
14504 elsif Chars
(Form
) = Name_Storage_Unit
then
14505 Atype
:= Calign_Storage_Unit
;
14509 ("invalid Form parameter for pragma%", Form
);
14512 -- The pragma appears in a configuration file
14514 if No
(Parent
(N
)) then
14515 Check_Valid_Configuration_Pragma
;
14517 -- Capture the component alignment in a global variable when
14518 -- the pragma appears in a configuration file. Note that the
14519 -- scope stack is empty at this point and cannot be used to
14520 -- store the alignment value.
14522 Configuration_Component_Alignment
:= Atype
;
14524 -- Case with no name, supplied, affects scope table entry
14526 elsif No
(Name
) then
14528 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14530 -- Case of name supplied
14533 Check_Arg_Is_Local_Name
(Name
);
14535 Typ
:= Entity
(Name
);
14538 or else Rep_Item_Too_Early
(Typ
, N
)
14542 Typ
:= Underlying_Type
(Typ
);
14545 if not Is_Record_Type
(Typ
)
14546 and then not Is_Array_Type
(Typ
)
14549 ("Name parameter of pragma% must identify record or "
14550 & "array type", Name
);
14553 -- An explicit Component_Alignment pragma overrides an
14554 -- implicit pragma Pack, but not an explicit one.
14556 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
14557 Set_Is_Packed
(Base_Type
(Typ
), False);
14558 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
14561 end Component_AlignmentP
;
14563 --------------------------------
14564 -- Constant_After_Elaboration --
14565 --------------------------------
14567 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14569 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
14571 Obj_Decl
: Node_Id
;
14572 Obj_Id
: Entity_Id
;
14576 Check_No_Identifiers
;
14577 Check_At_Most_N_Arguments
(1);
14579 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14581 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
14586 Obj_Id
:= Defining_Entity
(Obj_Decl
);
14588 -- The object declaration must be a library-level variable which
14589 -- is either explicitly initialized or obtains a value during the
14590 -- elaboration of a package body (SPARK RM 3.3.1).
14592 if Ekind
(Obj_Id
) = E_Variable
then
14593 if not Is_Library_Level_Entity
(Obj_Id
) then
14595 ("pragma % must apply to a library level variable");
14599 -- Otherwise the pragma applies to a constant, which is illegal
14602 Error_Pragma
("pragma % must apply to a variable declaration");
14606 -- A pragma that applies to a Ghost entity becomes Ghost for the
14607 -- purposes of legality checks and removal of ignored Ghost code.
14609 Mark_Ghost_Pragma
(N
, Obj_Id
);
14611 -- Chain the pragma on the contract for completeness
14613 Add_Contract_Item
(N
, Obj_Id
);
14615 -- Analyze the Boolean expression (if any)
14617 if Present
(Arg1
) then
14618 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14620 end Constant_After_Elaboration
;
14622 --------------------
14623 -- Contract_Cases --
14624 --------------------
14626 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14628 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14630 -- CASE_GUARD ::= boolean_EXPRESSION | others
14632 -- CONSEQUENCE ::= boolean_EXPRESSION
14634 -- Characteristics:
14636 -- * Analysis - The annotation undergoes initial checks to verify
14637 -- the legal placement and context. Secondary checks preanalyze the
14640 -- Analyze_Contract_Cases_In_Decl_Part
14642 -- * Expansion - The annotation is expanded during the expansion of
14643 -- the related subprogram [body] contract as performed in:
14645 -- Expand_Subprogram_Contract
14647 -- * Template - The annotation utilizes the generic template of the
14648 -- related subprogram [body] when it is:
14650 -- aspect on subprogram declaration
14651 -- aspect on stand-alone subprogram body
14652 -- pragma on stand-alone subprogram body
14654 -- The annotation must prepare its own template when it is:
14656 -- pragma on subprogram declaration
14658 -- * Globals - Capture of global references must occur after full
14661 -- * Instance - The annotation is instantiated automatically when
14662 -- the related generic subprogram [body] is instantiated except for
14663 -- the "pragma on subprogram declaration" case. In that scenario
14664 -- the annotation must instantiate itself.
14666 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14667 Spec_Id
: Entity_Id
;
14668 Subp_Decl
: Node_Id
;
14669 Subp_Spec
: Node_Id
;
14673 Check_No_Identifiers
;
14674 Check_Arg_Count
(1);
14676 -- Ensure the proper placement of the pragma. Contract_Cases must
14677 -- be associated with a subprogram declaration or a body that acts
14681 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14685 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14688 -- Generic subprogram
14690 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14693 -- Body acts as spec
14695 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14696 and then No
(Corresponding_Spec
(Subp_Decl
))
14700 -- Body stub acts as spec
14702 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14703 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14709 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14710 Subp_Spec
:= Specification
(Subp_Decl
);
14712 -- Pragma Contract_Cases is forbidden on null procedures, as
14713 -- this may lead to potential ambiguities in behavior when
14714 -- interface null procedures are involved.
14716 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14717 and then Null_Present
(Subp_Spec
)
14719 Error_Msg_N
(Fix_Error
14720 ("pragma % cannot apply to null procedure"), N
);
14729 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14731 -- A pragma that applies to a Ghost entity becomes Ghost for the
14732 -- purposes of legality checks and removal of ignored Ghost code.
14734 Mark_Ghost_Pragma
(N
, Spec_Id
);
14735 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14737 -- Chain the pragma on the contract for further processing by
14738 -- Analyze_Contract_Cases_In_Decl_Part.
14740 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14742 -- Fully analyze the pragma when it appears inside an entry
14743 -- or subprogram body because it cannot benefit from forward
14746 if Nkind
(Subp_Decl
) in N_Entry_Body
14747 | N_Subprogram_Body
14748 | N_Subprogram_Body_Stub
14750 -- The legality checks of pragma Contract_Cases are affected by
14751 -- the SPARK mode in effect and the volatility of the context.
14752 -- Analyze all pragmas in a specific order.
14754 Analyze_If_Present
(Pragma_SPARK_Mode
);
14755 Analyze_If_Present
(Pragma_Volatile_Function
);
14756 Analyze_Contract_Cases_In_Decl_Part
(N
);
14758 end Contract_Cases
;
14764 -- pragma Controlled (first_subtype_LOCAL_NAME);
14766 when Pragma_Controlled
=> Controlled
: declare
14770 Check_No_Identifiers
;
14771 Check_Arg_Count
(1);
14772 Check_Arg_Is_Local_Name
(Arg1
);
14773 Arg
:= Get_Pragma_Arg
(Arg1
);
14775 if not Is_Entity_Name
(Arg
)
14776 or else not Is_Access_Type
(Entity
(Arg
))
14778 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14780 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14788 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14789 -- [Entity =>] LOCAL_NAME);
14791 when Pragma_Convention
=> Convention
: declare
14794 pragma Warnings
(Off
, C
);
14795 pragma Warnings
(Off
, E
);
14798 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14799 Check_Ada_83_Warning
;
14800 Check_Arg_Count
(2);
14801 Process_Convention
(C
, E
);
14803 -- A pragma that applies to a Ghost entity becomes Ghost for the
14804 -- purposes of legality checks and removal of ignored Ghost code.
14806 Mark_Ghost_Pragma
(N
, E
);
14809 ---------------------------
14810 -- Convention_Identifier --
14811 ---------------------------
14813 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14814 -- [Convention =>] convention_IDENTIFIER);
14816 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14822 Check_Arg_Order
((Name_Name
, Name_Convention
));
14823 Check_Arg_Count
(2);
14824 Check_Optional_Identifier
(Arg1
, Name_Name
);
14825 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14826 Check_Arg_Is_Identifier
(Arg1
);
14827 Check_Arg_Is_Identifier
(Arg2
);
14828 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14829 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14831 if Is_Convention_Name
(Cname
) then
14832 Record_Convention_Identifier
14833 (Idnam
, Get_Convention_Id
(Cname
));
14836 ("second arg for % pragma must be convention", Arg2
);
14838 end Convention_Identifier
;
14844 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14846 when Pragma_CPP_Class
=>
14849 if Warn_On_Obsolescent_Feature
then
14851 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14852 & "effect; replace it by pragma import?j?", N
);
14855 Check_Arg_Count
(1);
14859 Chars
=> Name_Import
,
14860 Pragma_Argument_Associations
=> New_List
(
14861 Make_Pragma_Argument_Association
(Loc
,
14862 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14863 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14866 ---------------------
14867 -- CPP_Constructor --
14868 ---------------------
14870 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14871 -- [, [External_Name =>] static_string_EXPRESSION ]
14872 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14874 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14876 Def_Id
: Entity_Id
;
14877 Tag_Typ
: Entity_Id
;
14881 Check_At_Least_N_Arguments
(1);
14882 Check_At_Most_N_Arguments
(3);
14883 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14884 Check_Arg_Is_Local_Name
(Arg1
);
14886 Id
:= Get_Pragma_Arg
(Arg1
);
14887 Find_Program_Unit_Name
(Id
);
14889 -- If we did not find the name, we are done
14891 if Etype
(Id
) = Any_Type
then
14895 Def_Id
:= Entity
(Id
);
14897 -- Check if already defined as constructor
14899 if Is_Constructor
(Def_Id
) then
14901 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14905 if Ekind
(Def_Id
) = E_Function
14906 and then (Is_CPP_Class
(Etype
(Def_Id
))
14907 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14909 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14911 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14913 ("'C'P'P constructor must be defined in the scope of "
14914 & "its returned type", Arg1
);
14917 if Arg_Count
>= 2 then
14918 Set_Imported
(Def_Id
);
14919 Set_Is_Public
(Def_Id
);
14920 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14923 Set_Has_Completion
(Def_Id
);
14924 Set_Is_Constructor
(Def_Id
);
14925 Set_Convention
(Def_Id
, Convention_CPP
);
14927 -- Imported C++ constructors are not dispatching primitives
14928 -- because in C++ they don't have a dispatch table slot.
14929 -- However, in Ada the constructor has the profile of a
14930 -- function that returns a tagged type and therefore it has
14931 -- been treated as a primitive operation during semantic
14932 -- analysis. We now remove it from the list of primitive
14933 -- operations of the type.
14935 if Is_Tagged_Type
(Etype
(Def_Id
))
14936 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14937 and then Is_Dispatching_Operation
(Def_Id
)
14939 Tag_Typ
:= Etype
(Def_Id
);
14941 Remove
(Primitive_Operations
(Tag_Typ
), Def_Id
);
14942 Set_Is_Dispatching_Operation
(Def_Id
, False);
14945 -- For backward compatibility, if the constructor returns a
14946 -- class wide type, and we internally change the return type to
14947 -- the corresponding root type.
14949 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14950 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14954 ("pragma% requires function returning a 'C'P'P_Class type",
14957 end CPP_Constructor
;
14963 when Pragma_CPP_Virtual
=>
14966 if Warn_On_Obsolescent_Feature
then
14968 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14976 when Pragma_CUDA_Device
=> CUDA_Device
: declare
14977 Arg_Node
: Node_Id
;
14978 Device_Entity
: Entity_Id
;
14981 Check_Arg_Count
(1);
14982 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
14984 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
14985 Device_Entity
:= Entity
(Arg_Node
);
14987 if Ekind
(Device_Entity
) in E_Variable
14992 Add_CUDA_Device_Entity
14993 (Package_Specification_Of_Scope
(Scope
(Device_Entity
)),
14997 Error_Msg_NE
("& must be constant, variable or subprogram",
15008 -- pragma CUDA_Execute (PROCEDURE_CALL_STATEMENT,
15012 -- [, EXPRESSION]]);
15014 when Pragma_CUDA_Execute
=> CUDA_Execute
: declare
15016 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean;
15017 -- Returns True if N is an acceptable argument for CUDA_Execute,
15018 -- False otherwise.
15020 ------------------------
15021 -- Is_Acceptable_Dim3 --
15022 ------------------------
15024 function Is_Acceptable_Dim3
(N
: Node_Id
) return Boolean is
15027 if Is_RTE
(Etype
(N
), RE_Dim3
)
15028 or else Is_Integer_Type
(Etype
(N
))
15033 if Nkind
(N
) = N_Aggregate
15034 and then not Null_Record_Present
(N
)
15035 and then No
(Component_Associations
(N
))
15036 and then List_Length
(Expressions
(N
)) = 3
15038 Expr
:= First
(Expressions
(N
));
15039 while Present
(Expr
) loop
15040 Analyze_And_Resolve
(Expr
, Any_Integer
);
15047 end Is_Acceptable_Dim3
;
15051 Block_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg3
);
15052 Grid_Dimensions
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
15053 Kernel_Call
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
15054 Shared_Memory
: Node_Id
;
15057 -- Start of processing for CUDA_Execute
15061 Check_At_Least_N_Arguments
(3);
15062 Check_At_Most_N_Arguments
(5);
15064 Analyze_And_Resolve
(Kernel_Call
);
15065 if Nkind
(Kernel_Call
) /= N_Function_Call
15066 or else Etype
(Kernel_Call
) /= Standard_Void_Type
15068 -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`,
15069 -- GNAT sees Kernel_Call as an N_Function_Call since
15070 -- Kernel_Call "looks" like an expression. However, only
15071 -- procedures can be kernels, so to make things easier for the
15072 -- user the error message complains about Kernel_Call not being
15073 -- a procedure call.
15075 Error_Msg_N
("first argument of & must be a procedure call", N
);
15078 Analyze
(Grid_Dimensions
);
15079 if not Is_Acceptable_Dim3
(Grid_Dimensions
) then
15081 ("second argument of & must be an Integer, Dim3 or aggregate "
15082 & "containing 3 Integers", N
);
15085 Analyze
(Block_Dimensions
);
15086 if not Is_Acceptable_Dim3
(Block_Dimensions
) then
15088 ("third argument of & must be an Integer, Dim3 or aggregate "
15089 & "containing 3 Integers", N
);
15092 if Present
(Arg4
) then
15093 Shared_Memory
:= Get_Pragma_Arg
(Arg4
);
15094 Analyze_And_Resolve
(Shared_Memory
, Any_Integer
);
15096 if Present
(Arg5
) then
15097 Stream
:= Get_Pragma_Arg
(Arg5
);
15098 Analyze_And_Resolve
(Stream
, RTE
(RE_Stream_T
));
15107 -- pragma CUDA_Global ([Entity =>] IDENTIFIER);
15109 when Pragma_CUDA_Global
=> CUDA_Global
: declare
15110 Arg_Node
: Node_Id
;
15111 Kernel_Proc
: Entity_Id
;
15112 Pack_Id
: Entity_Id
;
15115 Check_Arg_Count
(1);
15116 Check_Optional_Identifier
(Arg1
, Name_Entity
);
15117 Check_Arg_Is_Local_Name
(Arg1
);
15119 Arg_Node
:= Get_Pragma_Arg
(Arg1
);
15120 Analyze
(Arg_Node
);
15122 Kernel_Proc
:= Entity
(Arg_Node
);
15123 Pack_Id
:= Scope
(Kernel_Proc
);
15125 if Ekind
(Kernel_Proc
) /= E_Procedure
then
15126 Error_Msg_NE
("& must be a procedure", N
, Kernel_Proc
);
15128 elsif Ekind
(Pack_Id
) /= E_Package
15129 or else not Is_Library_Level_Entity
(Pack_Id
)
15132 ("& must reside in a library-level package", N
, Kernel_Proc
);
15135 Set_Is_CUDA_Kernel
(Kernel_Proc
);
15136 Add_CUDA_Kernel
(Pack_Id
, Kernel_Proc
);
15144 when Pragma_CPP_Vtable
=>
15147 if Warn_On_Obsolescent_Feature
then
15149 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15157 -- pragma CPU (EXPRESSION);
15159 when Pragma_CPU
=> CPU
: declare
15160 P
: constant Node_Id
:= Parent
(N
);
15166 Check_No_Identifiers
;
15167 Check_Arg_Count
(1);
15168 Arg
:= Get_Pragma_Arg
(Arg1
);
15172 if Nkind
(P
) = N_Subprogram_Body
then
15173 Check_In_Main_Program
;
15175 Analyze_And_Resolve
(Arg
, Any_Integer
);
15177 Ent
:= Defining_Unit_Name
(Specification
(P
));
15179 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15180 Ent
:= Defining_Identifier
(Ent
);
15185 if not Is_OK_Static_Expression
(Arg
) then
15186 Flag_Non_Static_Expr
15187 ("main subprogram affinity is not static!", Arg
);
15190 -- If constraint error, then we already signalled an error
15192 elsif Raises_Constraint_Error
(Arg
) then
15195 -- Otherwise check in range
15199 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15200 -- This is the entity System.Multiprocessors.CPU_Range;
15202 Val
: constant Uint
:= Expr_Value
(Arg
);
15205 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15207 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15210 ("main subprogram CPU is out of range", Arg1
);
15216 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15220 elsif Nkind
(P
) = N_Task_Definition
then
15221 Ent
:= Defining_Identifier
(Parent
(P
));
15223 -- The expression must be analyzed in the special manner
15224 -- described in "Handling of Default and Per-Object
15225 -- Expressions" in sem.ads.
15227 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15229 -- See comment in Sem_Ch13 about the following restrictions
15231 if Is_OK_Static_Expression
(Arg
) then
15232 if Expr_Value
(Arg
) = Uint_0
then
15233 Check_Restriction
(No_Tasks_Unassigned_To_CPU
, N
);
15236 Check_Restriction
(No_Dynamic_CPU_Assignment
, N
);
15239 -- Anything else is incorrect
15245 -- Check duplicate pragma before we chain the pragma in the Rep
15246 -- Item chain of Ent.
15248 Check_Duplicate_Pragma
(Ent
);
15249 Record_Rep_Item
(Ent
, N
);
15252 --------------------
15253 -- Deadline_Floor --
15254 --------------------
15256 -- pragma Deadline_Floor (time_span_EXPRESSION);
15258 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15259 P
: constant Node_Id
:= Parent
(N
);
15265 Check_No_Identifiers
;
15266 Check_Arg_Count
(1);
15268 Arg
:= Get_Pragma_Arg
(Arg1
);
15270 -- The expression must be analyzed in the special manner described
15271 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15273 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15275 -- Only protected types allowed
15277 if Nkind
(P
) /= N_Protected_Definition
then
15281 Ent
:= Defining_Identifier
(Parent
(P
));
15283 -- Check duplicate pragma before we chain the pragma in the Rep
15284 -- Item chain of Ent.
15286 Check_Duplicate_Pragma
(Ent
);
15287 Record_Rep_Item
(Ent
, N
);
15289 end Deadline_Floor
;
15295 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15297 when Pragma_Debug
=> Debug
: declare
15304 -- The condition for executing the call is that the expander
15305 -- is active and that we are not ignoring this debug pragma.
15310 (Expander_Active
and then not Is_Ignored
(N
)),
15313 if not Is_Ignored
(N
) then
15314 Set_SCO_Pragma_Enabled
(Loc
);
15317 if Arg_Count
= 2 then
15319 Make_And_Then
(Loc
,
15320 Left_Opnd
=> Relocate_Node
(Cond
),
15321 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15322 Call
:= Get_Pragma_Arg
(Arg2
);
15324 Call
:= Get_Pragma_Arg
(Arg1
);
15327 if Nkind
(Call
) in N_Expanded_Name
15330 | N_Indexed_Component
15331 | N_Selected_Component
15333 -- If this pragma Debug comes from source, its argument was
15334 -- parsed as a name form (which is syntactically identical).
15335 -- In a generic context a parameterless call will be left as
15336 -- an expanded name (if global) or selected_component if local.
15337 -- Change it to a procedure call statement now.
15339 Change_Name_To_Procedure_Call_Statement
(Call
);
15341 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15343 -- Already in the form of a procedure call statement: nothing
15344 -- to do (could happen in case of an internally generated
15350 -- All other cases: diagnose error
15353 ("argument of pragma ""Debug"" is not procedure call", Call
);
15357 -- Rewrite into a conditional with an appropriate condition. We
15358 -- wrap the procedure call in a block so that overhead from e.g.
15359 -- use of the secondary stack does not generate execution overhead
15360 -- for suppressed conditions.
15362 -- Normally the analysis that follows will freeze the subprogram
15363 -- being called. However, if the call is to a null procedure,
15364 -- we want to freeze it before creating the block, because the
15365 -- analysis that follows may be done with expansion disabled, in
15366 -- which case the body will not be generated, leading to spurious
15369 if Nkind
(Call
) = N_Procedure_Call_Statement
15370 and then Is_Entity_Name
(Name
(Call
))
15372 Analyze
(Name
(Call
));
15373 Freeze_Before
(N
, Entity
(Name
(Call
)));
15377 Make_Implicit_If_Statement
(N
,
15379 Then_Statements
=> New_List
(
15380 Make_Block_Statement
(Loc
,
15381 Handled_Statement_Sequence
=>
15382 Make_Handled_Sequence_Of_Statements
(Loc
,
15383 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15386 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15387 -- after analysis of the normally rewritten node, to capture all
15388 -- references to entities, which avoids issuing wrong warnings
15389 -- about unused entities.
15391 if GNATprove_Mode
then
15392 Rewrite
(N
, Make_Null_Statement
(Loc
));
15400 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15402 when Pragma_Debug_Policy
=>
15404 Check_Arg_Count
(1);
15405 Check_No_Identifiers
;
15406 Check_Arg_Is_Identifier
(Arg1
);
15408 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15409 -- rewrite it that way, and let the rest of the checking come
15410 -- from analyzing the rewritten pragma.
15414 Chars
=> Name_Check_Policy
,
15415 Pragma_Argument_Associations
=> New_List
(
15416 Make_Pragma_Argument_Association
(Loc
,
15417 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15419 Make_Pragma_Argument_Association
(Loc
,
15420 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15423 -------------------------------
15424 -- Default_Initial_Condition --
15425 -------------------------------
15427 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15429 when Pragma_Default_Initial_Condition
=> DIC
: declare
15436 Check_No_Identifiers
;
15437 Check_At_Most_N_Arguments
(2); -- Accounts for implicit type arg
15441 while Present
(Stmt
) loop
15443 -- Skip prior pragmas, but check for duplicates
15445 if Nkind
(Stmt
) = N_Pragma
then
15446 if Pragma_Name
(Stmt
) = Pname
then
15453 -- Skip internally generated code. Note that derived type
15454 -- declarations of untagged types with discriminants are
15455 -- rewritten as private type declarations.
15457 elsif not Comes_From_Source
(Stmt
)
15458 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15462 -- The associated private type [extension] has been found, stop
15465 elsif Nkind
(Stmt
) in N_Private_Extension_Declaration
15466 | N_Private_Type_Declaration
15468 Typ
:= Defining_Entity
(Stmt
);
15471 -- The pragma does not apply to a legal construct, issue an
15472 -- error and stop the analysis.
15479 Stmt
:= Prev
(Stmt
);
15482 -- The pragma does not apply to a legal construct, issue an error
15483 -- and stop the analysis.
15490 -- A pragma that applies to a Ghost entity becomes Ghost for the
15491 -- purposes of legality checks and removal of ignored Ghost code.
15493 Mark_Ghost_Pragma
(N
, Typ
);
15495 -- The pragma signals that the type defines its own DIC assertion
15498 Set_Has_Own_DIC
(Typ
);
15500 -- A type entity argument is appended to facilitate inheriting the
15501 -- aspect/pragma from parent types (see Build_DIC_Procedure_Body),
15502 -- though that extra argument isn't documented for the pragma.
15504 if not Present
(Arg2
) then
15505 -- When the pragma has no arguments, create an argument with
15506 -- the value Empty, so the type name argument can be appended
15507 -- following it (since it's expected as the second argument).
15509 if not Present
(Arg1
) then
15510 Set_Pragma_Argument_Associations
(N
, New_List
(
15511 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15512 Expression
=> Empty
)));
15516 (Pragma_Argument_Associations
(N
),
15517 Make_Pragma_Argument_Association
(Sloc
(Typ
),
15518 Expression
=> New_Occurrence_Of
(Typ
, Sloc
(Typ
))));
15521 -- Chain the pragma on the rep item chain for further processing
15523 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15525 -- Create the declaration of the procedure which verifies the
15526 -- assertion expression of pragma DIC at runtime.
15528 Build_DIC_Procedure_Declaration
(Typ
);
15531 ----------------------------------
15532 -- Default_Scalar_Storage_Order --
15533 ----------------------------------
15535 -- pragma Default_Scalar_Storage_Order
15536 -- (High_Order_First | Low_Order_First);
15538 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15539 Default
: Character;
15543 Check_Arg_Count
(1);
15545 -- Default_Scalar_Storage_Order can appear as a configuration
15546 -- pragma, or in a declarative part of a package spec.
15548 if not Is_Configuration_Pragma
then
15549 Check_Is_In_Decl_Part_Or_Package_Spec
;
15552 Check_No_Identifiers
;
15553 Check_Arg_Is_One_Of
15554 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
15555 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15556 Default
:= Fold_Upper
(Name_Buffer
(1));
15558 if not Support_Nondefault_SSO_On_Target
15559 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
15561 if Warn_On_Unrecognized_Pragma
then
15563 ("non-default Scalar_Storage_Order not supported "
15564 & "on target?g?", N
);
15566 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
15569 -- Here set the specified default
15572 Opt
.Default_SSO
:= Default
;
15576 --------------------------
15577 -- Default_Storage_Pool --
15578 --------------------------
15580 -- pragma Default_Storage_Pool (storage_pool_NAME | null | Standard);
15582 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
15587 Check_Arg_Count
(1);
15589 -- Default_Storage_Pool can appear as a configuration pragma, or
15590 -- in a declarative part of a package spec.
15592 if not Is_Configuration_Pragma
then
15593 Check_Is_In_Decl_Part_Or_Package_Spec
;
15596 if From_Aspect_Specification
(N
) then
15598 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
15600 if not In_Open_Scopes
(E
) then
15602 ("aspect must apply to package or subprogram", N
);
15607 if Present
(Arg1
) then
15608 Pool
:= Get_Pragma_Arg
(Arg1
);
15610 -- Case of Default_Storage_Pool (null);
15612 if Nkind
(Pool
) = N_Null
then
15615 -- This is an odd case, this is not really an expression,
15616 -- so we don't have a type for it. So just set the type to
15619 Set_Etype
(Pool
, Empty
);
15621 -- Case of Default_Storage_Pool (Standard);
15623 elsif Nkind
(Pool
) = N_Identifier
15624 and then Chars
(Pool
) = Name_Standard
15628 if Entity
(Pool
) /= Standard_Standard
then
15630 ("package Standard is not directly visible", Arg1
);
15633 -- Case of Default_Storage_Pool (storage_pool_NAME);
15636 -- If it's a configuration pragma, then the only allowed
15637 -- argument is "null".
15639 if Is_Configuration_Pragma
then
15640 Error_Pragma_Arg
("NULL or Standard expected", Arg1
);
15643 -- The expected type for a non-"null" argument is
15644 -- Root_Storage_Pool'Class, and the pool must be a variable.
15646 Analyze_And_Resolve
15647 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
15649 if Is_Variable
(Pool
) then
15651 -- A pragma that applies to a Ghost entity becomes Ghost
15652 -- for the purposes of legality checks and removal of
15653 -- ignored Ghost code.
15655 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
15659 ("default storage pool must be a variable", Arg1
);
15663 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15664 -- access type will use this information to set the appropriate
15665 -- attributes of the access type. If the pragma appears in a
15666 -- generic unit it is ignored, given that it may refer to a
15669 if not Inside_A_Generic
then
15670 Default_Pool
:= Pool
;
15673 end Default_Storage_Pool
;
15679 -- pragma Depends (DEPENDENCY_RELATION);
15681 -- DEPENDENCY_RELATION ::=
15683 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15685 -- DEPENDENCY_CLAUSE ::=
15686 -- OUTPUT_LIST =>[+] INPUT_LIST
15687 -- | NULL_DEPENDENCY_CLAUSE
15689 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15691 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15693 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15695 -- OUTPUT ::= NAME | FUNCTION_RESULT
15698 -- where FUNCTION_RESULT is a function Result attribute_reference
15700 -- Characteristics:
15702 -- * Analysis - The annotation undergoes initial checks to verify
15703 -- the legal placement and context. Secondary checks fully analyze
15704 -- the dependency clauses in:
15706 -- Analyze_Depends_In_Decl_Part
15708 -- * Expansion - None.
15710 -- * Template - The annotation utilizes the generic template of the
15711 -- related subprogram [body] when it is:
15713 -- aspect on subprogram declaration
15714 -- aspect on stand-alone subprogram body
15715 -- pragma on stand-alone subprogram body
15717 -- The annotation must prepare its own template when it is:
15719 -- pragma on subprogram declaration
15721 -- * Globals - Capture of global references must occur after full
15724 -- * Instance - The annotation is instantiated automatically when
15725 -- the related generic subprogram [body] is instantiated except for
15726 -- the "pragma on subprogram declaration" case. In that scenario
15727 -- the annotation must instantiate itself.
15729 when Pragma_Depends
=> Depends
: declare
15731 Spec_Id
: Entity_Id
;
15732 Subp_Decl
: Node_Id
;
15735 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15739 -- Chain the pragma on the contract for further processing by
15740 -- Analyze_Depends_In_Decl_Part.
15742 Add_Contract_Item
(N
, Spec_Id
);
15744 -- Fully analyze the pragma when it appears inside an entry
15745 -- or subprogram body because it cannot benefit from forward
15748 if Nkind
(Subp_Decl
) in N_Entry_Body
15749 | N_Subprogram_Body
15750 | N_Subprogram_Body_Stub
15752 -- The legality checks of pragmas Depends and Global are
15753 -- affected by the SPARK mode in effect and the volatility
15754 -- of the context. In addition these two pragmas are subject
15755 -- to an inherent order:
15760 -- Analyze all these pragmas in the order outlined above
15762 Analyze_If_Present
(Pragma_SPARK_Mode
);
15763 Analyze_If_Present
(Pragma_Volatile_Function
);
15764 Analyze_If_Present
(Pragma_Global
);
15765 Analyze_Depends_In_Decl_Part
(N
);
15770 ---------------------
15771 -- Detect_Blocking --
15772 ---------------------
15774 -- pragma Detect_Blocking;
15776 when Pragma_Detect_Blocking
=>
15778 Check_Arg_Count
(0);
15779 Check_Valid_Configuration_Pragma
;
15780 Detect_Blocking
:= True;
15782 ------------------------------------
15783 -- Disable_Atomic_Synchronization --
15784 ------------------------------------
15786 -- pragma Disable_Atomic_Synchronization [(Entity)];
15788 when Pragma_Disable_Atomic_Synchronization
=>
15790 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
15792 -------------------
15793 -- Discard_Names --
15794 -------------------
15796 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15798 when Pragma_Discard_Names
=> Discard_Names
: declare
15803 Check_Ada_83_Warning
;
15805 -- Deal with configuration pragma case
15807 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
15808 Global_Discard_Names
:= True;
15811 -- Otherwise, check correct appropriate context
15814 Check_Is_In_Decl_Part_Or_Package_Spec
;
15816 if Arg_Count
= 0 then
15818 -- If there is no parameter, then from now on this pragma
15819 -- applies to any enumeration, exception or tagged type
15820 -- defined in the current declarative part, and recursively
15821 -- to any nested scope.
15823 Set_Discard_Names
(Current_Scope
);
15827 Check_Arg_Count
(1);
15828 Check_Optional_Identifier
(Arg1
, Name_On
);
15829 Check_Arg_Is_Local_Name
(Arg1
);
15831 E_Id
:= Get_Pragma_Arg
(Arg1
);
15833 if Etype
(E_Id
) = Any_Type
then
15837 E
:= Entity
(E_Id
);
15839 -- A pragma that applies to a Ghost entity becomes Ghost for
15840 -- the purposes of legality checks and removal of ignored
15843 Mark_Ghost_Pragma
(N
, E
);
15845 if (Is_First_Subtype
(E
)
15847 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
15848 or else Ekind
(E
) = E_Exception
15850 Set_Discard_Names
(E
);
15851 Record_Rep_Item
(E
, N
);
15855 ("inappropriate entity for pragma%", Arg1
);
15861 ------------------------
15862 -- Dispatching_Domain --
15863 ------------------------
15865 -- pragma Dispatching_Domain (EXPRESSION);
15867 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15868 P
: constant Node_Id
:= Parent
(N
);
15874 Check_No_Identifiers
;
15875 Check_Arg_Count
(1);
15877 -- This pragma is born obsolete, but not the aspect
15879 if not From_Aspect_Specification
(N
) then
15881 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15884 if Nkind
(P
) = N_Task_Definition
then
15885 Arg
:= Get_Pragma_Arg
(Arg1
);
15886 Ent
:= Defining_Identifier
(Parent
(P
));
15888 -- A pragma that applies to a Ghost entity becomes Ghost for
15889 -- the purposes of legality checks and removal of ignored Ghost
15892 Mark_Ghost_Pragma
(N
, Ent
);
15894 -- The expression must be analyzed in the special manner
15895 -- described in "Handling of Default and Per-Object
15896 -- Expressions" in sem.ads.
15898 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15900 -- Check duplicate pragma before we chain the pragma in the Rep
15901 -- Item chain of Ent.
15903 Check_Duplicate_Pragma
(Ent
);
15904 Record_Rep_Item
(Ent
, N
);
15906 -- Anything else is incorrect
15911 end Dispatching_Domain
;
15917 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15919 when Pragma_Elaborate
=> Elaborate
: declare
15924 -- Pragma must be in context items list of a compilation unit
15926 if not Is_In_Context_Clause
then
15930 -- Must be at least one argument
15932 if Arg_Count
= 0 then
15933 Error_Pragma
("pragma% requires at least one argument");
15936 -- In Ada 83 mode, there can be no items following it in the
15937 -- context list except other pragmas and implicit with clauses
15938 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15939 -- placement rule does not apply.
15941 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15943 while Present
(Citem
) loop
15944 if Nkind
(Citem
) = N_Pragma
15945 or else (Nkind
(Citem
) = N_With_Clause
15946 and then Implicit_With
(Citem
))
15951 ("(Ada 83) pragma% must be at end of context clause");
15958 -- Finally, the arguments must all be units mentioned in a with
15959 -- clause in the same context clause. Note we already checked (in
15960 -- Par.Prag) that the arguments are all identifiers or selected
15964 Outer
: while Present
(Arg
) loop
15965 Citem
:= First
(List_Containing
(N
));
15966 Inner
: while Citem
/= N
loop
15967 if Nkind
(Citem
) = N_With_Clause
15968 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15970 Set_Elaborate_Present
(Citem
, True);
15971 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15973 -- With the pragma present, elaboration calls on
15974 -- subprograms from the named unit need no further
15975 -- checks, as long as the pragma appears in the current
15976 -- compilation unit. If the pragma appears in some unit
15977 -- in the context, there might still be a need for an
15978 -- Elaborate_All_Desirable from the current compilation
15979 -- to the named unit, so we keep the check enabled. This
15980 -- does not apply in SPARK mode, where we allow pragma
15981 -- Elaborate, but we don't trust it to be right so we
15982 -- will still insist on the Elaborate_All.
15984 if Legacy_Elaboration_Checks
15985 and then In_Extended_Main_Source_Unit
(N
)
15986 and then SPARK_Mode
/= On
15988 Set_Suppress_Elaboration_Warnings
15989 (Entity
(Name
(Citem
)));
16000 ("argument of pragma% is not withed unit", Arg
);
16007 -------------------
16008 -- Elaborate_All --
16009 -------------------
16011 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
16013 when Pragma_Elaborate_All
=> Elaborate_All
: declare
16018 Check_Ada_83_Warning
;
16020 -- Pragma must be in context items list of a compilation unit
16022 if not Is_In_Context_Clause
then
16026 -- Must be at least one argument
16028 if Arg_Count
= 0 then
16029 Error_Pragma
("pragma% requires at least one argument");
16032 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
16033 -- have to appear at the end of the context clause, but may
16034 -- appear mixed in with other items, even in Ada 83 mode.
16036 -- Final check: the arguments must all be units mentioned in
16037 -- a with clause in the same context clause. Note that we
16038 -- already checked (in Par.Prag) that all the arguments are
16039 -- either identifiers or selected components.
16042 Outr
: while Present
(Arg
) loop
16043 Citem
:= First
(List_Containing
(N
));
16044 Innr
: while Citem
/= N
loop
16045 if Nkind
(Citem
) = N_With_Clause
16046 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
16048 Set_Elaborate_All_Present
(Citem
, True);
16049 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
16051 -- Suppress warnings and elaboration checks on the named
16052 -- unit if the pragma is in the current compilation, as
16053 -- for pragma Elaborate.
16055 if Legacy_Elaboration_Checks
16056 and then In_Extended_Main_Source_Unit
(N
)
16058 Set_Suppress_Elaboration_Warnings
16059 (Entity
(Name
(Citem
)));
16069 Set_Error_Posted
(N
);
16071 ("argument of pragma% is not withed unit", Arg
);
16078 --------------------
16079 -- Elaborate_Body --
16080 --------------------
16082 -- pragma Elaborate_Body [( library_unit_NAME )];
16084 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
16085 Cunit_Node
: Node_Id
;
16086 Cunit_Ent
: Entity_Id
;
16089 Check_Ada_83_Warning
;
16090 Check_Valid_Library_Unit_Pragma
;
16092 -- If N was rewritten as a null statement there is nothing more
16095 if Nkind
(N
) = N_Null_Statement
then
16099 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
16100 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
16102 -- A pragma that applies to a Ghost entity becomes Ghost for the
16103 -- purposes of legality checks and removal of ignored Ghost code.
16105 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
16107 if Nkind
(Unit
(Cunit_Node
)) in
16108 N_Package_Body | N_Subprogram_Body
16110 Error_Pragma
("pragma% must refer to a spec, not a body");
16112 Set_Body_Required
(Cunit_Node
);
16113 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
16115 -- If we are in dynamic elaboration mode, then we suppress
16116 -- elaboration warnings for the unit, since it is definitely
16117 -- fine NOT to do dynamic checks at the first level (and such
16118 -- checks will be suppressed because no elaboration boolean
16119 -- is created for Elaborate_Body packages).
16121 -- But in the static model of elaboration, Elaborate_Body is
16122 -- definitely NOT good enough to ensure elaboration safety on
16123 -- its own, since the body may WITH other units that are not
16124 -- safe from an elaboration point of view, so a client must
16125 -- still do an Elaborate_All on such units.
16127 -- Debug flag -gnatdD restores the old behavior of 3.13, where
16128 -- Elaborate_Body always suppressed elab warnings.
16130 if Legacy_Elaboration_Checks
16131 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
16133 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
16136 end Elaborate_Body
;
16138 ------------------------
16139 -- Elaboration_Checks --
16140 ------------------------
16142 -- pragma Elaboration_Checks (Static | Dynamic);
16144 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
16145 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
16146 -- Emit an error if the current context list already contains
16147 -- a previous Elaboration_Checks pragma. This routine raises
16148 -- Pragma_Exit if a duplicate is found.
16150 procedure Ignore_Elaboration_Checks_Pragma
;
16151 -- Warn that the effects of the pragma are ignored. This routine
16152 -- raises Pragma_Exit.
16154 -----------------------------------------------
16155 -- Check_Duplicate_Elaboration_Checks_Pragma --
16156 -----------------------------------------------
16158 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16163 while Present
(Item
) loop
16164 if Nkind
(Item
) = N_Pragma
16165 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16175 end Check_Duplicate_Elaboration_Checks_Pragma
;
16177 --------------------------------------
16178 -- Ignore_Elaboration_Checks_Pragma --
16179 --------------------------------------
16181 procedure Ignore_Elaboration_Checks_Pragma
is
16183 Error_Msg_Name_1
:= Pname
;
16184 Error_Msg_N
("??effects of pragma % are ignored", N
);
16186 ("\place pragma on initial declaration of library unit", N
);
16189 end Ignore_Elaboration_Checks_Pragma
;
16193 Context
: constant Node_Id
:= Parent
(N
);
16196 -- Start of processing for Elaboration_Checks
16200 Check_Arg_Count
(1);
16201 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16203 -- The pragma appears in a configuration file
16205 if No
(Context
) then
16206 Check_Valid_Configuration_Pragma
;
16207 Check_Duplicate_Elaboration_Checks_Pragma
;
16209 -- The pragma acts as a configuration pragma in a compilation unit
16211 -- pragma Elaboration_Checks (...);
16212 -- package Pack is ...;
16214 elsif Nkind
(Context
) = N_Compilation_Unit
16215 and then List_Containing
(N
) = Context_Items
(Context
)
16217 Check_Valid_Configuration_Pragma
;
16218 Check_Duplicate_Elaboration_Checks_Pragma
;
16220 Unt
:= Unit
(Context
);
16222 -- The pragma must appear on the initial declaration of a unit.
16223 -- If this is not the case, warn that the effects of the pragma
16226 if Nkind
(Unt
) = N_Package_Body
then
16227 Ignore_Elaboration_Checks_Pragma
;
16229 -- Check the Acts_As_Spec flag of the compilation units itself
16230 -- to determine whether the subprogram body completes since it
16231 -- has not been analyzed yet. This is safe because compilation
16232 -- units are not overloadable.
16234 elsif Nkind
(Unt
) = N_Subprogram_Body
16235 and then not Acts_As_Spec
(Context
)
16237 Ignore_Elaboration_Checks_Pragma
;
16239 elsif Nkind
(Unt
) = N_Subunit
then
16240 Ignore_Elaboration_Checks_Pragma
;
16243 -- Otherwise the pragma does not appear at the configuration level
16250 -- At this point the pragma is not a duplicate, and appears in the
16251 -- proper context. Set the elaboration model in effect.
16253 Dynamic_Elaboration_Checks
:=
16254 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16255 end Elaboration_Checks
;
16261 -- pragma Eliminate (
16262 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16263 -- [Entity =>] IDENTIFIER |
16264 -- SELECTED_COMPONENT |
16266 -- [, Source_Location => SOURCE_TRACE]);
16268 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16269 -- SOURCE_TRACE ::= STRING_LITERAL
16271 when Pragma_Eliminate
=> Eliminate
: declare
16272 Args
: Args_List
(1 .. 5);
16273 Names
: constant Name_List
(1 .. 5) := (
16276 Name_Parameter_Types
,
16278 Name_Source_Location
);
16280 -- Note : Parameter_Types and Result_Type are leftovers from
16281 -- prior implementations of the pragma. They are not generated
16282 -- by the gnatelim tool, and play no role in selecting which
16283 -- of a set of overloaded names is chosen for elimination.
16285 Unit_Name
: Node_Id
renames Args
(1);
16286 Entity
: Node_Id
renames Args
(2);
16287 Parameter_Types
: Node_Id
renames Args
(3);
16288 Result_Type
: Node_Id
renames Args
(4);
16289 Source_Location
: Node_Id
renames Args
(5);
16293 Check_Valid_Configuration_Pragma
;
16294 Gather_Associations
(Names
, Args
);
16296 if No
(Unit_Name
) then
16297 Error_Pragma
("missing Unit_Name argument for pragma%");
16301 and then (Present
(Parameter_Types
)
16303 Present
(Result_Type
)
16305 Present
(Source_Location
))
16307 Error_Pragma
("missing Entity argument for pragma%");
16310 if (Present
(Parameter_Types
)
16312 Present
(Result_Type
))
16314 Present
(Source_Location
)
16317 ("parameter profile and source location cannot be used "
16318 & "together in pragma%");
16321 Process_Eliminate_Pragma
16330 -----------------------------------
16331 -- Enable_Atomic_Synchronization --
16332 -----------------------------------
16334 -- pragma Enable_Atomic_Synchronization [(Entity)];
16336 when Pragma_Enable_Atomic_Synchronization
=>
16338 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16345 -- [ Convention =>] convention_IDENTIFIER,
16346 -- [ Entity =>] LOCAL_NAME
16347 -- [, [External_Name =>] static_string_EXPRESSION ]
16348 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16350 when Pragma_Export
=> Export
: declare
16352 Def_Id
: Entity_Id
;
16354 pragma Warnings
(Off
, C
);
16357 Check_Ada_83_Warning
;
16361 Name_External_Name
,
16364 Check_At_Least_N_Arguments
(2);
16365 Check_At_Most_N_Arguments
(4);
16367 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16368 -- pragma Export (Entity, "external name");
16370 if Relaxed_RM_Semantics
16371 and then Arg_Count
= 2
16372 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16375 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16378 if not Is_Entity_Name
(Def_Id
) then
16379 Error_Pragma_Arg
("entity name required", Arg1
);
16382 Def_Id
:= Entity
(Def_Id
);
16383 Set_Exported
(Def_Id
, Arg1
);
16386 Process_Convention
(C
, Def_Id
);
16388 -- A pragma that applies to a Ghost entity becomes Ghost for
16389 -- the purposes of legality checks and removal of ignored Ghost
16392 Mark_Ghost_Pragma
(N
, Def_Id
);
16394 if Ekind
(Def_Id
) /= E_Constant
then
16395 Note_Possible_Modification
16396 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16399 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
16400 Set_Exported
(Def_Id
, Arg2
);
16403 -- If the entity is a deferred constant, propagate the information
16404 -- to the full view, because gigi elaborates the full view only.
16406 if Ekind
(Def_Id
) = E_Constant
16407 and then Present
(Full_View
(Def_Id
))
16410 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
16412 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
16413 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
16415 (Id2
, Einfo
.Entities
.Interface_Name
(Def_Id
));
16420 ---------------------
16421 -- Export_Function --
16422 ---------------------
16424 -- pragma Export_Function (
16425 -- [Internal =>] LOCAL_NAME
16426 -- [, [External =>] EXTERNAL_SYMBOL]
16427 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16428 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16429 -- [, [Mechanism =>] MECHANISM]
16430 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16432 -- EXTERNAL_SYMBOL ::=
16434 -- | static_string_EXPRESSION
16436 -- PARAMETER_TYPES ::=
16438 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16440 -- TYPE_DESIGNATOR ::=
16442 -- | subtype_Name ' Access
16446 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16448 -- MECHANISM_ASSOCIATION ::=
16449 -- [formal_parameter_NAME =>] MECHANISM_NAME
16451 -- MECHANISM_NAME ::=
16455 when Pragma_Export_Function
=> Export_Function
: declare
16456 Args
: Args_List
(1 .. 6);
16457 Names
: constant Name_List
(1 .. 6) := (
16460 Name_Parameter_Types
,
16463 Name_Result_Mechanism
);
16465 Internal
: Node_Id
renames Args
(1);
16466 External
: Node_Id
renames Args
(2);
16467 Parameter_Types
: Node_Id
renames Args
(3);
16468 Result_Type
: Node_Id
renames Args
(4);
16469 Mechanism
: Node_Id
renames Args
(5);
16470 Result_Mechanism
: Node_Id
renames Args
(6);
16474 Gather_Associations
(Names
, Args
);
16475 Process_Extended_Import_Export_Subprogram_Pragma
(
16476 Arg_Internal
=> Internal
,
16477 Arg_External
=> External
,
16478 Arg_Parameter_Types
=> Parameter_Types
,
16479 Arg_Result_Type
=> Result_Type
,
16480 Arg_Mechanism
=> Mechanism
,
16481 Arg_Result_Mechanism
=> Result_Mechanism
);
16482 end Export_Function
;
16484 -------------------
16485 -- Export_Object --
16486 -------------------
16488 -- pragma Export_Object (
16489 -- [Internal =>] LOCAL_NAME
16490 -- [, [External =>] EXTERNAL_SYMBOL]
16491 -- [, [Size =>] EXTERNAL_SYMBOL]);
16493 -- EXTERNAL_SYMBOL ::=
16495 -- | static_string_EXPRESSION
16497 -- PARAMETER_TYPES ::=
16499 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16501 -- TYPE_DESIGNATOR ::=
16503 -- | subtype_Name ' Access
16507 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16509 -- MECHANISM_ASSOCIATION ::=
16510 -- [formal_parameter_NAME =>] MECHANISM_NAME
16512 -- MECHANISM_NAME ::=
16516 when Pragma_Export_Object
=> Export_Object
: declare
16517 Args
: Args_List
(1 .. 3);
16518 Names
: constant Name_List
(1 .. 3) := (
16523 Internal
: Node_Id
renames Args
(1);
16524 External
: Node_Id
renames Args
(2);
16525 Size
: Node_Id
renames Args
(3);
16529 Gather_Associations
(Names
, Args
);
16530 Process_Extended_Import_Export_Object_Pragma
(
16531 Arg_Internal
=> Internal
,
16532 Arg_External
=> External
,
16536 ----------------------
16537 -- Export_Procedure --
16538 ----------------------
16540 -- pragma Export_Procedure (
16541 -- [Internal =>] LOCAL_NAME
16542 -- [, [External =>] EXTERNAL_SYMBOL]
16543 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16544 -- [, [Mechanism =>] MECHANISM]);
16546 -- EXTERNAL_SYMBOL ::=
16548 -- | static_string_EXPRESSION
16550 -- PARAMETER_TYPES ::=
16552 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16554 -- TYPE_DESIGNATOR ::=
16556 -- | subtype_Name ' Access
16560 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16562 -- MECHANISM_ASSOCIATION ::=
16563 -- [formal_parameter_NAME =>] MECHANISM_NAME
16565 -- MECHANISM_NAME ::=
16569 when Pragma_Export_Procedure
=> Export_Procedure
: declare
16570 Args
: Args_List
(1 .. 4);
16571 Names
: constant Name_List
(1 .. 4) := (
16574 Name_Parameter_Types
,
16577 Internal
: Node_Id
renames Args
(1);
16578 External
: Node_Id
renames Args
(2);
16579 Parameter_Types
: Node_Id
renames Args
(3);
16580 Mechanism
: Node_Id
renames Args
(4);
16584 Gather_Associations
(Names
, Args
);
16585 Process_Extended_Import_Export_Subprogram_Pragma
(
16586 Arg_Internal
=> Internal
,
16587 Arg_External
=> External
,
16588 Arg_Parameter_Types
=> Parameter_Types
,
16589 Arg_Mechanism
=> Mechanism
);
16590 end Export_Procedure
;
16592 -----------------------------
16593 -- Export_Valued_Procedure --
16594 -----------------------------
16596 -- pragma Export_Valued_Procedure (
16597 -- [Internal =>] LOCAL_NAME
16598 -- [, [External =>] EXTERNAL_SYMBOL,]
16599 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16600 -- [, [Mechanism =>] MECHANISM]);
16602 -- EXTERNAL_SYMBOL ::=
16604 -- | static_string_EXPRESSION
16606 -- PARAMETER_TYPES ::=
16608 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16610 -- TYPE_DESIGNATOR ::=
16612 -- | subtype_Name ' Access
16616 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16618 -- MECHANISM_ASSOCIATION ::=
16619 -- [formal_parameter_NAME =>] MECHANISM_NAME
16621 -- MECHANISM_NAME ::=
16625 when Pragma_Export_Valued_Procedure
=>
16626 Export_Valued_Procedure
: declare
16627 Args
: Args_List
(1 .. 4);
16628 Names
: constant Name_List
(1 .. 4) := (
16631 Name_Parameter_Types
,
16634 Internal
: Node_Id
renames Args
(1);
16635 External
: Node_Id
renames Args
(2);
16636 Parameter_Types
: Node_Id
renames Args
(3);
16637 Mechanism
: Node_Id
renames Args
(4);
16641 Gather_Associations
(Names
, Args
);
16642 Process_Extended_Import_Export_Subprogram_Pragma
(
16643 Arg_Internal
=> Internal
,
16644 Arg_External
=> External
,
16645 Arg_Parameter_Types
=> Parameter_Types
,
16646 Arg_Mechanism
=> Mechanism
);
16647 end Export_Valued_Procedure
;
16649 -------------------
16650 -- Extend_System --
16651 -------------------
16653 -- pragma Extend_System ([Name =>] Identifier);
16655 when Pragma_Extend_System
=>
16657 Check_Valid_Configuration_Pragma
;
16658 Check_Arg_Count
(1);
16659 Check_Optional_Identifier
(Arg1
, Name_Name
);
16660 Check_Arg_Is_Identifier
(Arg1
);
16662 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16665 and then Name_Buffer
(1 .. 4) = "aux_"
16667 if Present
(System_Extend_Pragma_Arg
) then
16668 if Chars
(Get_Pragma_Arg
(Arg1
)) =
16669 Chars
(Expression
(System_Extend_Pragma_Arg
))
16673 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
16674 Error_Pragma
("pragma% conflicts with that #");
16678 System_Extend_Pragma_Arg
:= Arg1
;
16680 if not GNAT_Mode
then
16681 System_Extend_Unit
:= Arg1
;
16685 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
16688 ------------------------
16689 -- Extensions_Allowed --
16690 ------------------------
16692 -- pragma Extensions_Allowed (ON | OFF);
16694 when Pragma_Extensions_Allowed
=>
16696 Check_Arg_Count
(1);
16697 Check_No_Identifiers
;
16698 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
16700 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
16701 Ada_Version
:= Ada_With_Extensions
;
16703 Ada_Version
:= Ada_Version_Explicit
;
16704 Ada_Version_Pragma
:= Empty
;
16707 ------------------------
16708 -- Extensions_Visible --
16709 ------------------------
16711 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16713 -- Characteristics:
16715 -- * Analysis - The annotation is fully analyzed immediately upon
16716 -- elaboration as its expression must be static.
16718 -- * Expansion - None.
16720 -- * Template - The annotation utilizes the generic template of the
16721 -- related subprogram [body] when it is:
16723 -- aspect on subprogram declaration
16724 -- aspect on stand-alone subprogram body
16725 -- pragma on stand-alone subprogram body
16727 -- The annotation must prepare its own template when it is:
16729 -- pragma on subprogram declaration
16731 -- * Globals - Capture of global references must occur after full
16734 -- * Instance - The annotation is instantiated automatically when
16735 -- the related generic subprogram [body] is instantiated except for
16736 -- the "pragma on subprogram declaration" case. In that scenario
16737 -- the annotation must instantiate itself.
16739 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
16740 Formal
: Entity_Id
;
16741 Has_OK_Formal
: Boolean := False;
16742 Spec_Id
: Entity_Id
;
16743 Subp_Decl
: Node_Id
;
16747 Check_No_Identifiers
;
16748 Check_At_Most_N_Arguments
(1);
16751 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16753 -- Abstract subprogram declaration
16755 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
16758 -- Generic subprogram declaration
16760 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16763 -- Body acts as spec
16765 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16766 and then No
(Corresponding_Spec
(Subp_Decl
))
16770 -- Body stub acts as spec
16772 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16773 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16777 -- Subprogram declaration
16779 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16782 -- Otherwise the pragma is associated with an illegal construct
16785 Error_Pragma
("pragma % must apply to a subprogram");
16789 -- Mark the pragma as Ghost if the related subprogram is also
16790 -- Ghost. This also ensures that any expansion performed further
16791 -- below will produce Ghost nodes.
16793 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16794 Mark_Ghost_Pragma
(N
, Spec_Id
);
16796 -- Chain the pragma on the contract for completeness
16798 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16800 -- The legality checks of pragma Extension_Visible are affected
16801 -- by the SPARK mode in effect. Analyze all pragmas in specific
16804 Analyze_If_Present
(Pragma_SPARK_Mode
);
16806 -- Examine the formals of the related subprogram
16808 Formal
:= First_Formal
(Spec_Id
);
16809 while Present
(Formal
) loop
16811 -- At least one of the formals is of a specific tagged type,
16812 -- the pragma is legal.
16814 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
16815 Has_OK_Formal
:= True;
16818 -- A generic subprogram with at least one formal of a private
16819 -- type ensures the legality of the pragma because the actual
16820 -- may be specifically tagged. Note that this is verified by
16821 -- the check above at instantiation time.
16823 elsif Is_Private_Type
(Etype
(Formal
))
16824 and then Is_Generic_Type
(Etype
(Formal
))
16826 Has_OK_Formal
:= True;
16830 Next_Formal
(Formal
);
16833 if not Has_OK_Formal
then
16834 Error_Msg_Name_1
:= Pname
;
16835 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
16837 ("\subprogram & lacks parameter of specific tagged or "
16838 & "generic private type", N
, Spec_Id
);
16843 -- Analyze the Boolean expression (if any)
16845 if Present
(Arg1
) then
16846 Check_Static_Boolean_Expression
16847 (Expression
(Get_Argument
(N
, Spec_Id
)));
16849 end Extensions_Visible
;
16855 -- pragma External (
16856 -- [ Convention =>] convention_IDENTIFIER,
16857 -- [ Entity =>] LOCAL_NAME
16858 -- [, [External_Name =>] static_string_EXPRESSION ]
16859 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16861 when Pragma_External
=> External
: declare
16864 pragma Warnings
(Off
, C
);
16871 Name_External_Name
,
16873 Check_At_Least_N_Arguments
(2);
16874 Check_At_Most_N_Arguments
(4);
16875 Process_Convention
(C
, E
);
16877 -- A pragma that applies to a Ghost entity becomes Ghost for the
16878 -- purposes of legality checks and removal of ignored Ghost code.
16880 Mark_Ghost_Pragma
(N
, E
);
16882 Note_Possible_Modification
16883 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16884 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16885 Set_Exported
(E
, Arg2
);
16888 --------------------------
16889 -- External_Name_Casing --
16890 --------------------------
16892 -- pragma External_Name_Casing (
16893 -- UPPERCASE | LOWERCASE
16894 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16896 when Pragma_External_Name_Casing
=>
16898 Check_No_Identifiers
;
16900 if Arg_Count
= 2 then
16901 Check_Arg_Is_One_Of
16902 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16904 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16906 Opt
.External_Name_Exp_Casing
:= As_Is
;
16908 when Name_Uppercase
=>
16909 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16911 when Name_Lowercase
=>
16912 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16919 Check_Arg_Count
(1);
16922 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16924 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16925 when Name_Uppercase
=>
16926 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16928 when Name_Lowercase
=>
16929 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16939 -- pragma Fast_Math;
16941 when Pragma_Fast_Math
=>
16943 Check_No_Identifiers
;
16944 Check_Valid_Configuration_Pragma
;
16947 --------------------------
16948 -- Favor_Top_Level --
16949 --------------------------
16951 -- pragma Favor_Top_Level (type_NAME);
16953 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16958 Check_No_Identifiers
;
16959 Check_Arg_Count
(1);
16960 Check_Arg_Is_Local_Name
(Arg1
);
16961 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16963 -- A pragma that applies to a Ghost entity becomes Ghost for the
16964 -- purposes of legality checks and removal of ignored Ghost code.
16966 Mark_Ghost_Pragma
(N
, Typ
);
16968 -- If it's an access-to-subprogram type (in particular, not a
16969 -- subtype), set the flag on that type.
16971 if Is_Access_Subprogram_Type
(Typ
) then
16972 Set_Can_Use_Internal_Rep
(Typ
, False);
16974 -- Otherwise it's an error (name denotes the wrong sort of entity)
16978 ("access-to-subprogram type expected",
16979 Get_Pragma_Arg
(Arg1
));
16981 end Favor_Top_Level
;
16983 ---------------------------
16984 -- Finalize_Storage_Only --
16985 ---------------------------
16987 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16989 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16990 Assoc
: constant Node_Id
:= Arg1
;
16991 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16996 Check_No_Identifiers
;
16997 Check_Arg_Count
(1);
16998 Check_Arg_Is_Local_Name
(Arg1
);
17000 Find_Type
(Type_Id
);
17001 Typ
:= Entity
(Type_Id
);
17004 or else Rep_Item_Too_Early
(Typ
, N
)
17008 Typ
:= Underlying_Type
(Typ
);
17011 if not Is_Controlled
(Typ
) then
17012 Error_Pragma
("pragma% must specify controlled type");
17015 Check_First_Subtype
(Arg1
);
17017 if Finalize_Storage_Only
(Typ
) then
17018 Error_Pragma
("duplicate pragma%, only one allowed");
17020 elsif not Rep_Item_Too_Late
(Typ
, N
) then
17021 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
17023 end Finalize_Storage
;
17029 -- pragma Ghost [ (boolean_EXPRESSION) ];
17031 when Pragma_Ghost
=> Ghost
: declare
17035 Orig_Stmt
: Node_Id
;
17036 Prev_Id
: Entity_Id
;
17041 Check_No_Identifiers
;
17042 Check_At_Most_N_Arguments
(1);
17046 while Present
(Stmt
) loop
17048 -- Skip prior pragmas, but check for duplicates
17050 if Nkind
(Stmt
) = N_Pragma
then
17051 if Pragma_Name
(Stmt
) = Pname
then
17058 -- Task unit declared without a definition cannot be subject to
17059 -- pragma Ghost (SPARK RM 6.9(19)).
17061 elsif Nkind
(Stmt
) in
17062 N_Single_Task_Declaration | N_Task_Type_Declaration
17064 Error_Pragma
("pragma % cannot apply to a task type");
17067 -- Skip internally generated code
17069 elsif not Comes_From_Source
(Stmt
) then
17070 Orig_Stmt
:= Original_Node
(Stmt
);
17072 -- When pragma Ghost applies to an untagged derivation, the
17073 -- derivation is transformed into a [sub]type declaration.
17076 N_Full_Type_Declaration | N_Subtype_Declaration
17077 and then Comes_From_Source
(Orig_Stmt
)
17078 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
17079 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
17080 N_Derived_Type_Definition
17082 Id
:= Defining_Entity
(Stmt
);
17085 -- When pragma Ghost applies to an object declaration which
17086 -- is initialized by means of a function call that returns
17087 -- on the secondary stack, the object declaration becomes a
17090 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
17091 and then Comes_From_Source
(Orig_Stmt
)
17092 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
17094 Id
:= Defining_Entity
(Stmt
);
17097 -- When pragma Ghost applies to an expression function, the
17098 -- expression function is transformed into a subprogram.
17100 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
17101 and then Comes_From_Source
(Orig_Stmt
)
17102 and then Nkind
(Orig_Stmt
) = N_Expression_Function
17104 Id
:= Defining_Entity
(Stmt
);
17108 -- The pragma applies to a legal construct, stop the traversal
17110 elsif Nkind
(Stmt
) in N_Abstract_Subprogram_Declaration
17111 | N_Full_Type_Declaration
17112 | N_Generic_Subprogram_Declaration
17113 | N_Object_Declaration
17114 | N_Private_Extension_Declaration
17115 | N_Private_Type_Declaration
17116 | N_Subprogram_Declaration
17117 | N_Subtype_Declaration
17119 Id
:= Defining_Entity
(Stmt
);
17122 -- The pragma does not apply to a legal construct, issue an
17123 -- error and stop the analysis.
17127 ("pragma % must apply to an object, package, subprogram "
17132 Stmt
:= Prev
(Stmt
);
17135 Context
:= Parent
(N
);
17137 -- Handle compilation units
17139 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17140 Context
:= Unit
(Parent
(Context
));
17143 -- Protected and task types cannot be subject to pragma Ghost
17144 -- (SPARK RM 6.9(19)).
17146 if Nkind
(Context
) in N_Protected_Body | N_Protected_Definition
17148 Error_Pragma
("pragma % cannot apply to a protected type");
17151 elsif Nkind
(Context
) in N_Task_Body | N_Task_Definition
then
17152 Error_Pragma
("pragma % cannot apply to a task type");
17158 -- When pragma Ghost is associated with a [generic] package, it
17159 -- appears in the visible declarations.
17161 if Nkind
(Context
) = N_Package_Specification
17162 and then Present
(Visible_Declarations
(Context
))
17163 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17165 Id
:= Defining_Entity
(Context
);
17167 -- Pragma Ghost applies to a stand-alone subprogram body
17169 elsif Nkind
(Context
) = N_Subprogram_Body
17170 and then No
(Corresponding_Spec
(Context
))
17172 Id
:= Defining_Entity
(Context
);
17174 -- Pragma Ghost applies to a subprogram declaration that acts
17175 -- as a compilation unit.
17177 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17178 Id
:= Defining_Entity
(Context
);
17180 -- Pragma Ghost applies to a generic subprogram
17182 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17183 Id
:= Defining_Entity
(Specification
(Context
));
17189 ("pragma % must apply to an object, package, subprogram or "
17194 -- Handle completions of types and constants that are subject to
17197 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17198 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17200 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17201 Error_Msg_Name_1
:= Pname
;
17203 -- The full declaration of a deferred constant cannot be
17204 -- subject to pragma Ghost unless the deferred declaration
17205 -- is also Ghost (SPARK RM 6.9(9)).
17207 if Ekind
(Prev_Id
) = E_Constant
then
17208 Error_Msg_Name_1
:= Pname
;
17209 Error_Msg_NE
(Fix_Error
17210 ("pragma % must apply to declaration of deferred "
17211 & "constant &"), N
, Id
);
17214 -- Pragma Ghost may appear on the full view of an incomplete
17215 -- type because the incomplete declaration lacks aspects and
17216 -- cannot be subject to pragma Ghost.
17218 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17221 -- The full declaration of a type cannot be subject to
17222 -- pragma Ghost unless the partial view is also Ghost
17223 -- (SPARK RM 6.9(9)).
17226 Error_Msg_NE
(Fix_Error
17227 ("pragma % must apply to partial view of type &"),
17233 -- A synchronized object cannot be subject to pragma Ghost
17234 -- (SPARK RM 6.9(19)).
17236 elsif Ekind
(Id
) = E_Variable
then
17237 if Is_Protected_Type
(Etype
(Id
)) then
17238 Error_Pragma
("pragma % cannot apply to a protected object");
17241 elsif Is_Task_Type
(Etype
(Id
)) then
17242 Error_Pragma
("pragma % cannot apply to a task object");
17247 -- Analyze the Boolean expression (if any)
17249 if Present
(Arg1
) then
17250 Expr
:= Get_Pragma_Arg
(Arg1
);
17252 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17254 if Is_OK_Static_Expression
(Expr
) then
17256 -- "Ghostness" cannot be turned off once enabled within a
17257 -- region (SPARK RM 6.9(6)).
17259 if Is_False
(Expr_Value
(Expr
))
17260 and then Ghost_Mode
> None
17263 ("pragma % with value False cannot appear in enabled "
17268 -- Otherwise the expression is not static
17272 ("expression of pragma % must be static", Expr
);
17277 Set_Is_Ghost_Entity
(Id
);
17284 -- pragma Global (GLOBAL_SPECIFICATION);
17286 -- GLOBAL_SPECIFICATION ::=
17289 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17291 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17293 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17294 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17295 -- GLOBAL_ITEM ::= NAME
17297 -- Characteristics:
17299 -- * Analysis - The annotation undergoes initial checks to verify
17300 -- the legal placement and context. Secondary checks fully analyze
17301 -- the dependency clauses in:
17303 -- Analyze_Global_In_Decl_Part
17305 -- * Expansion - None.
17307 -- * Template - The annotation utilizes the generic template of the
17308 -- related subprogram [body] when it is:
17310 -- aspect on subprogram declaration
17311 -- aspect on stand-alone subprogram body
17312 -- pragma on stand-alone subprogram body
17314 -- The annotation must prepare its own template when it is:
17316 -- pragma on subprogram declaration
17318 -- * Globals - Capture of global references must occur after full
17321 -- * Instance - The annotation is instantiated automatically when
17322 -- the related generic subprogram [body] is instantiated except for
17323 -- the "pragma on subprogram declaration" case. In that scenario
17324 -- the annotation must instantiate itself.
17326 when Pragma_Global
=> Global
: declare
17328 Spec_Id
: Entity_Id
;
17329 Subp_Decl
: Node_Id
;
17332 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17336 -- Chain the pragma on the contract for further processing by
17337 -- Analyze_Global_In_Decl_Part.
17339 Add_Contract_Item
(N
, Spec_Id
);
17341 -- Fully analyze the pragma when it appears inside an entry
17342 -- or subprogram body because it cannot benefit from forward
17345 if Nkind
(Subp_Decl
) in N_Entry_Body
17346 | N_Subprogram_Body
17347 | N_Subprogram_Body_Stub
17349 -- The legality checks of pragmas Depends and Global are
17350 -- affected by the SPARK mode in effect and the volatility
17351 -- of the context. In addition these two pragmas are subject
17352 -- to an inherent order:
17357 -- Analyze all these pragmas in the order outlined above
17359 Analyze_If_Present
(Pragma_SPARK_Mode
);
17360 Analyze_If_Present
(Pragma_Volatile_Function
);
17361 Analyze_Global_In_Decl_Part
(N
);
17362 Analyze_If_Present
(Pragma_Depends
);
17371 -- pragma Ident (static_string_EXPRESSION)
17373 -- Note: pragma Comment shares this processing. Pragma Ident is
17374 -- identical in effect to pragma Commment.
17376 when Pragma_Comment
17384 Check_Arg_Count
(1);
17385 Check_No_Identifiers
;
17386 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17389 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
17396 GP
:= Parent
(Parent
(N
));
17399 N_Package_Declaration | N_Generic_Package_Declaration
17404 -- If we have a compilation unit, then record the ident value,
17405 -- checking for improper duplication.
17407 if Nkind
(GP
) = N_Compilation_Unit
then
17408 CS
:= Ident_String
(Current_Sem_Unit
);
17410 if Present
(CS
) then
17412 -- If we have multiple instances, concatenate them.
17414 Start_String
(Strval
(CS
));
17415 Store_String_Char
(' ');
17416 Store_String_Chars
(Strval
(Str
));
17417 Set_Strval
(CS
, End_String
);
17420 Set_Ident_String
(Current_Sem_Unit
, Str
);
17423 -- For subunits, we just ignore the Ident, since in GNAT these
17424 -- are not separate object files, and hence not separate units
17425 -- in the unit table.
17427 elsif Nkind
(GP
) = N_Subunit
then
17433 -------------------
17434 -- Ignore_Pragma --
17435 -------------------
17437 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17439 -- Entirely handled in the parser, nothing to do here
17441 when Pragma_Ignore_Pragma
=>
17444 ----------------------------
17445 -- Implementation_Defined --
17446 ----------------------------
17448 -- pragma Implementation_Defined (LOCAL_NAME);
17450 -- Marks previously declared entity as implementation defined. For
17451 -- an overloaded entity, applies to the most recent homonym.
17453 -- pragma Implementation_Defined;
17455 -- The form with no arguments appears anywhere within a scope, most
17456 -- typically a package spec, and indicates that all entities that are
17457 -- defined within the package spec are Implementation_Defined.
17459 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
17464 Check_No_Identifiers
;
17466 -- Form with no arguments
17468 if Arg_Count
= 0 then
17469 Set_Is_Implementation_Defined
(Current_Scope
);
17471 -- Form with one argument
17474 Check_Arg_Count
(1);
17475 Check_Arg_Is_Local_Name
(Arg1
);
17476 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17477 Set_Is_Implementation_Defined
(Ent
);
17479 end Implementation_Defined
;
17485 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17487 -- IMPLEMENTATION_KIND ::=
17488 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17490 -- "By_Any" and "Optional" are treated as synonyms in order to
17491 -- support Ada 2012 aspect Synchronization.
17493 when Pragma_Implemented
=> Implemented
: declare
17494 Proc_Id
: Entity_Id
;
17499 Check_Arg_Count
(2);
17500 Check_No_Identifiers
;
17501 Check_Arg_Is_Identifier
(Arg1
);
17502 Check_Arg_Is_Local_Name
(Arg1
);
17503 Check_Arg_Is_One_Of
(Arg2
,
17506 Name_By_Protected_Procedure
,
17509 -- Extract the name of the local procedure
17511 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17513 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17514 -- primitive procedure of a synchronized tagged type.
17516 if Ekind
(Proc_Id
) = E_Procedure
17517 and then Is_Primitive
(Proc_Id
)
17518 and then Present
(First_Formal
(Proc_Id
))
17520 Typ
:= Etype
(First_Formal
(Proc_Id
));
17522 if Is_Tagged_Type
(Typ
)
17525 -- Check for a protected, a synchronized or a task interface
17527 ((Is_Interface
(Typ
)
17528 and then Is_Synchronized_Interface
(Typ
))
17530 -- Check for a protected type or a task type that implements
17534 (Is_Concurrent_Record_Type
(Typ
)
17535 and then Present
(Interfaces
(Typ
)))
17537 -- In analysis-only mode, examine original protected type
17540 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
17541 and then Present
(Interface_List
(Parent
(Typ
))))
17543 -- Check for a private record extension with keyword
17547 (Ekind
(Typ
) in E_Record_Type_With_Private
17548 | E_Record_Subtype_With_Private
17549 and then Synchronized_Present
(Parent
(Typ
))))
17554 ("controlling formal must be of synchronized tagged type",
17559 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17560 -- By_Protected_Procedure to the primitive procedure of a task
17563 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
17564 and then Is_Interface
(Typ
)
17565 and then Is_Task_Interface
(Typ
)
17568 ("implementation kind By_Protected_Procedure cannot be "
17569 & "applied to a task interface primitive", Arg2
);
17573 -- Procedures declared inside a protected type must be accepted
17575 elsif Ekind
(Proc_Id
) = E_Procedure
17576 and then Is_Protected_Type
(Scope
(Proc_Id
))
17580 -- The first argument is not a primitive procedure
17584 ("pragma % must be applied to a primitive procedure", Arg1
);
17588 -- Ada 2012 (AI12-0279): Cannot apply the implementation_kind
17589 -- By_Protected_Procedure to a procedure that has aspect Yield
17591 if Chars
(Get_Pragma_Arg
(Arg2
)) = Name_By_Protected_Procedure
17592 and then Has_Yield_Aspect
(Proc_Id
)
17595 ("implementation kind By_Protected_Procedure cannot be "
17596 & "applied to entities with aspect 'Yield", Arg2
);
17600 Record_Rep_Item
(Proc_Id
, N
);
17603 ----------------------
17604 -- Implicit_Packing --
17605 ----------------------
17607 -- pragma Implicit_Packing;
17609 when Pragma_Implicit_Packing
=>
17611 Check_Arg_Count
(0);
17612 Implicit_Packing
:= True;
17619 -- [Convention =>] convention_IDENTIFIER,
17620 -- [Entity =>] LOCAL_NAME
17621 -- [, [External_Name =>] static_string_EXPRESSION ]
17622 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17624 when Pragma_Import
=>
17625 Check_Ada_83_Warning
;
17629 Name_External_Name
,
17632 Check_At_Least_N_Arguments
(2);
17633 Check_At_Most_N_Arguments
(4);
17634 Process_Import_Or_Interface
;
17636 ---------------------
17637 -- Import_Function --
17638 ---------------------
17640 -- pragma Import_Function (
17641 -- [Internal =>] LOCAL_NAME,
17642 -- [, [External =>] EXTERNAL_SYMBOL]
17643 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17644 -- [, [Result_Type =>] SUBTYPE_MARK]
17645 -- [, [Mechanism =>] MECHANISM]
17646 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17648 -- EXTERNAL_SYMBOL ::=
17650 -- | static_string_EXPRESSION
17652 -- PARAMETER_TYPES ::=
17654 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17656 -- TYPE_DESIGNATOR ::=
17658 -- | subtype_Name ' Access
17662 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17664 -- MECHANISM_ASSOCIATION ::=
17665 -- [formal_parameter_NAME =>] MECHANISM_NAME
17667 -- MECHANISM_NAME ::=
17671 when Pragma_Import_Function
=> Import_Function
: declare
17672 Args
: Args_List
(1 .. 6);
17673 Names
: constant Name_List
(1 .. 6) := (
17676 Name_Parameter_Types
,
17679 Name_Result_Mechanism
);
17681 Internal
: Node_Id
renames Args
(1);
17682 External
: Node_Id
renames Args
(2);
17683 Parameter_Types
: Node_Id
renames Args
(3);
17684 Result_Type
: Node_Id
renames Args
(4);
17685 Mechanism
: Node_Id
renames Args
(5);
17686 Result_Mechanism
: Node_Id
renames Args
(6);
17690 Gather_Associations
(Names
, Args
);
17691 Process_Extended_Import_Export_Subprogram_Pragma
(
17692 Arg_Internal
=> Internal
,
17693 Arg_External
=> External
,
17694 Arg_Parameter_Types
=> Parameter_Types
,
17695 Arg_Result_Type
=> Result_Type
,
17696 Arg_Mechanism
=> Mechanism
,
17697 Arg_Result_Mechanism
=> Result_Mechanism
);
17698 end Import_Function
;
17700 -------------------
17701 -- Import_Object --
17702 -------------------
17704 -- pragma Import_Object (
17705 -- [Internal =>] LOCAL_NAME
17706 -- [, [External =>] EXTERNAL_SYMBOL]
17707 -- [, [Size =>] EXTERNAL_SYMBOL]);
17709 -- EXTERNAL_SYMBOL ::=
17711 -- | static_string_EXPRESSION
17713 when Pragma_Import_Object
=> Import_Object
: declare
17714 Args
: Args_List
(1 .. 3);
17715 Names
: constant Name_List
(1 .. 3) := (
17720 Internal
: Node_Id
renames Args
(1);
17721 External
: Node_Id
renames Args
(2);
17722 Size
: Node_Id
renames Args
(3);
17726 Gather_Associations
(Names
, Args
);
17727 Process_Extended_Import_Export_Object_Pragma
(
17728 Arg_Internal
=> Internal
,
17729 Arg_External
=> External
,
17733 ----------------------
17734 -- Import_Procedure --
17735 ----------------------
17737 -- pragma Import_Procedure (
17738 -- [Internal =>] LOCAL_NAME
17739 -- [, [External =>] EXTERNAL_SYMBOL]
17740 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17741 -- [, [Mechanism =>] MECHANISM]);
17743 -- EXTERNAL_SYMBOL ::=
17745 -- | static_string_EXPRESSION
17747 -- PARAMETER_TYPES ::=
17749 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17751 -- TYPE_DESIGNATOR ::=
17753 -- | subtype_Name ' Access
17757 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17759 -- MECHANISM_ASSOCIATION ::=
17760 -- [formal_parameter_NAME =>] MECHANISM_NAME
17762 -- MECHANISM_NAME ::=
17766 when Pragma_Import_Procedure
=> Import_Procedure
: declare
17767 Args
: Args_List
(1 .. 4);
17768 Names
: constant Name_List
(1 .. 4) := (
17771 Name_Parameter_Types
,
17774 Internal
: Node_Id
renames Args
(1);
17775 External
: Node_Id
renames Args
(2);
17776 Parameter_Types
: Node_Id
renames Args
(3);
17777 Mechanism
: Node_Id
renames Args
(4);
17781 Gather_Associations
(Names
, Args
);
17782 Process_Extended_Import_Export_Subprogram_Pragma
(
17783 Arg_Internal
=> Internal
,
17784 Arg_External
=> External
,
17785 Arg_Parameter_Types
=> Parameter_Types
,
17786 Arg_Mechanism
=> Mechanism
);
17787 end Import_Procedure
;
17789 -----------------------------
17790 -- Import_Valued_Procedure --
17791 -----------------------------
17793 -- pragma Import_Valued_Procedure (
17794 -- [Internal =>] LOCAL_NAME
17795 -- [, [External =>] EXTERNAL_SYMBOL]
17796 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17797 -- [, [Mechanism =>] MECHANISM]);
17799 -- EXTERNAL_SYMBOL ::=
17801 -- | static_string_EXPRESSION
17803 -- PARAMETER_TYPES ::=
17805 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17807 -- TYPE_DESIGNATOR ::=
17809 -- | subtype_Name ' Access
17813 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17815 -- MECHANISM_ASSOCIATION ::=
17816 -- [formal_parameter_NAME =>] MECHANISM_NAME
17818 -- MECHANISM_NAME ::=
17822 when Pragma_Import_Valued_Procedure
=>
17823 Import_Valued_Procedure
: declare
17824 Args
: Args_List
(1 .. 4);
17825 Names
: constant Name_List
(1 .. 4) := (
17828 Name_Parameter_Types
,
17831 Internal
: Node_Id
renames Args
(1);
17832 External
: Node_Id
renames Args
(2);
17833 Parameter_Types
: Node_Id
renames Args
(3);
17834 Mechanism
: Node_Id
renames Args
(4);
17838 Gather_Associations
(Names
, Args
);
17839 Process_Extended_Import_Export_Subprogram_Pragma
(
17840 Arg_Internal
=> Internal
,
17841 Arg_External
=> External
,
17842 Arg_Parameter_Types
=> Parameter_Types
,
17843 Arg_Mechanism
=> Mechanism
);
17844 end Import_Valued_Procedure
;
17850 -- pragma Independent (LOCAL_NAME);
17852 when Pragma_Independent
=>
17853 Process_Atomic_Independent_Shared_Volatile
;
17855 ----------------------------
17856 -- Independent_Components --
17857 ----------------------------
17859 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17861 when Pragma_Independent_Components
=> Independent_Components
: declare
17868 Check_Ada_83_Warning
;
17870 Check_No_Identifiers
;
17871 Check_Arg_Count
(1);
17872 Check_Arg_Is_Local_Name
(Arg1
);
17873 E_Id
:= Get_Pragma_Arg
(Arg1
);
17875 if Etype
(E_Id
) = Any_Type
then
17879 E
:= Entity
(E_Id
);
17881 -- A record type with a self-referential component of anonymous
17882 -- access type is given an incomplete view in order to handle the
17885 -- type Rec is record
17886 -- Self : access Rec;
17892 -- type Ptr is access Rec;
17893 -- type Rec is record
17897 -- Since the incomplete view is now the initial view of the type,
17898 -- the argument of the pragma will reference the incomplete view,
17899 -- but this view is illegal according to the semantics of the
17902 -- Obtain the full view of an internally-generated incomplete type
17903 -- only. This way an attempt to associate the pragma with a source
17904 -- incomplete type is still caught.
17906 if Ekind
(E
) = E_Incomplete_Type
17907 and then not Comes_From_Source
(E
)
17908 and then Present
(Full_View
(E
))
17910 E
:= Full_View
(E
);
17913 -- A pragma that applies to a Ghost entity becomes Ghost for the
17914 -- purposes of legality checks and removal of ignored Ghost code.
17916 Mark_Ghost_Pragma
(N
, E
);
17918 -- Check duplicate before we chain ourselves
17920 Check_Duplicate_Pragma
(E
);
17922 -- Check appropriate entity
17924 if Rep_Item_Too_Early
(E
, N
)
17926 Rep_Item_Too_Late
(E
, N
)
17931 D
:= Declaration_Node
(E
);
17933 -- The flag is set on the base type, or on the object
17935 if Nkind
(D
) = N_Full_Type_Declaration
17936 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17938 Set_Has_Independent_Components
(Base_Type
(E
));
17939 Record_Independence_Check
(N
, Base_Type
(E
));
17941 -- For record type, set all components independent
17943 if Is_Record_Type
(E
) then
17944 C
:= First_Component
(E
);
17945 while Present
(C
) loop
17946 Set_Is_Independent
(C
);
17947 Next_Component
(C
);
17951 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17952 and then Nkind
(D
) = N_Object_Declaration
17953 and then Nkind
(Object_Definition
(D
)) =
17954 N_Constrained_Array_Definition
17956 Set_Has_Independent_Components
(E
);
17957 Record_Independence_Check
(N
, E
);
17960 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17962 end Independent_Components
;
17964 -----------------------
17965 -- Initial_Condition --
17966 -----------------------
17968 -- pragma Initial_Condition (boolean_EXPRESSION);
17970 -- Characteristics:
17972 -- * Analysis - The annotation undergoes initial checks to verify
17973 -- the legal placement and context. Secondary checks preanalyze the
17976 -- Analyze_Initial_Condition_In_Decl_Part
17978 -- * Expansion - The annotation is expanded during the expansion of
17979 -- the package body whose declaration is subject to the annotation
17982 -- Expand_Pragma_Initial_Condition
17984 -- * Template - The annotation utilizes the generic template of the
17985 -- related package declaration.
17987 -- * Globals - Capture of global references must occur after full
17990 -- * Instance - The annotation is instantiated automatically when
17991 -- the related generic package is instantiated.
17993 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17994 Pack_Decl
: Node_Id
;
17995 Pack_Id
: Entity_Id
;
17999 Check_No_Identifiers
;
18000 Check_Arg_Count
(1);
18002 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18004 if Nkind
(Pack_Decl
) not in
18005 N_Generic_Package_Declaration | N_Package_Declaration
18011 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18013 -- A pragma that applies to a Ghost entity becomes Ghost for the
18014 -- purposes of legality checks and removal of ignored Ghost code.
18016 Mark_Ghost_Pragma
(N
, Pack_Id
);
18018 -- Chain the pragma on the contract for further processing by
18019 -- Analyze_Initial_Condition_In_Decl_Part.
18021 Add_Contract_Item
(N
, Pack_Id
);
18023 -- The legality checks of pragmas Abstract_State, Initializes, and
18024 -- Initial_Condition are affected by the SPARK mode in effect. In
18025 -- addition, these three pragmas are subject to an inherent order:
18027 -- 1) Abstract_State
18029 -- 3) Initial_Condition
18031 -- Analyze all these pragmas in the order outlined above
18033 Analyze_If_Present
(Pragma_SPARK_Mode
);
18034 Analyze_If_Present
(Pragma_Abstract_State
);
18035 Analyze_If_Present
(Pragma_Initializes
);
18036 end Initial_Condition
;
18038 ------------------------
18039 -- Initialize_Scalars --
18040 ------------------------
18042 -- pragma Initialize_Scalars
18043 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
18045 -- TYPE_VALUE_PAIR ::=
18046 -- SCALAR_TYPE => static_EXPRESSION
18052 -- | Long_Long_Float
18064 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
18065 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
18066 -- This collection holds the individual pairs which specify the
18067 -- invalid values of their respective scalar types.
18069 procedure Analyze_Float_Value
18070 (Scal_Typ
: Float_Scalar_Id
;
18071 Val_Expr
: Node_Id
);
18072 -- Analyze a type value pair associated with float type Scal_Typ
18073 -- and expression Val_Expr.
18075 procedure Analyze_Integer_Value
18076 (Scal_Typ
: Integer_Scalar_Id
;
18077 Val_Expr
: Node_Id
);
18078 -- Analyze a type value pair associated with integer type Scal_Typ
18079 -- and expression Val_Expr.
18081 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
18082 -- Analyze type value pair Pair
18084 -------------------------
18085 -- Analyze_Float_Value --
18086 -------------------------
18088 procedure Analyze_Float_Value
18089 (Scal_Typ
: Float_Scalar_Id
;
18090 Val_Expr
: Node_Id
)
18093 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
18095 if Is_OK_Static_Expression
(Val_Expr
) then
18096 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
18099 Error_Msg_Name_1
:= Scal_Typ
;
18100 Error_Msg_N
("value for type % must be static", Val_Expr
);
18102 end Analyze_Float_Value
;
18104 ---------------------------
18105 -- Analyze_Integer_Value --
18106 ---------------------------
18108 procedure Analyze_Integer_Value
18109 (Scal_Typ
: Integer_Scalar_Id
;
18110 Val_Expr
: Node_Id
)
18113 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
18115 if (Scal_Typ
= Name_Signed_128
18116 or else Scal_Typ
= Name_Unsigned_128
)
18117 and then Ttypes
.System_Max_Integer_Size
< 128
18119 Error_Msg_Name_1
:= Scal_Typ
;
18120 Error_Msg_N
("value cannot be set for type %", Val_Expr
);
18122 elsif Is_OK_Static_Expression
(Val_Expr
) then
18123 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
18126 Error_Msg_Name_1
:= Scal_Typ
;
18127 Error_Msg_N
("value for type % must be static", Val_Expr
);
18129 end Analyze_Integer_Value
;
18131 -----------------------------
18132 -- Analyze_Type_Value_Pair --
18133 -----------------------------
18135 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
18136 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
18137 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
18138 Prev_Pair
: Node_Id
;
18141 if Scal_Typ
in Scalar_Id
then
18142 Prev_Pair
:= Seen
(Scal_Typ
);
18144 -- Prevent multiple attempts to set a value for a scalar
18147 if Present
(Prev_Pair
) then
18148 Error_Msg_Name_1
:= Scal_Typ
;
18150 ("cannot specify multiple invalid values for type %",
18153 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18154 Error_Msg_N
("previous value set #", Pair
);
18156 -- Ignore the effects of the pair, but do not halt the
18157 -- analysis of the pragma altogether.
18161 -- Otherwise capture the first pair for this scalar type
18164 Seen
(Scal_Typ
) := Pair
;
18167 if Scal_Typ
in Float_Scalar_Id
then
18168 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18170 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18171 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18174 -- Otherwise the scalar family is illegal
18177 Error_Msg_Name_1
:= Pname
;
18179 ("argument of pragma % must denote valid scalar family",
18182 end Analyze_Type_Value_Pair
;
18186 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18189 -- Start of processing for Do_Initialize_Scalars
18193 Check_Valid_Configuration_Pragma
;
18194 Check_Restriction
(No_Initialize_Scalars
, N
);
18196 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18199 if Restriction_Active
(No_Initialize_Scalars
) then
18202 -- Initialize_Scalars creates false positives in CodePeer, and
18203 -- incorrect negative results in GNATprove mode, so ignore this
18204 -- pragma in these modes.
18206 elsif CodePeer_Mode
or GNATprove_Mode
then
18209 -- Otherwise analyze the pragma
18212 if Present
(Pairs
) then
18214 -- Install Standard in order to provide access to primitive
18215 -- types in case the expressions contain attributes such as
18218 Push_Scope
(Standard_Standard
);
18220 Pair
:= First
(Pairs
);
18221 while Present
(Pair
) loop
18222 Analyze_Type_Value_Pair
(Pair
);
18231 Init_Or_Norm_Scalars
:= True;
18232 Initialize_Scalars
:= True;
18234 end Do_Initialize_Scalars
;
18240 -- pragma Initializes (INITIALIZATION_LIST);
18242 -- INITIALIZATION_LIST ::=
18244 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18246 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18251 -- | (INPUT {, INPUT})
18255 -- Characteristics:
18257 -- * Analysis - The annotation undergoes initial checks to verify
18258 -- the legal placement and context. Secondary checks preanalyze the
18261 -- Analyze_Initializes_In_Decl_Part
18263 -- * Expansion - None.
18265 -- * Template - The annotation utilizes the generic template of the
18266 -- related package declaration.
18268 -- * Globals - Capture of global references must occur after full
18271 -- * Instance - The annotation is instantiated automatically when
18272 -- the related generic package is instantiated.
18274 when Pragma_Initializes
=> Initializes
: declare
18275 Pack_Decl
: Node_Id
;
18276 Pack_Id
: Entity_Id
;
18280 Check_No_Identifiers
;
18281 Check_Arg_Count
(1);
18283 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18285 if Nkind
(Pack_Decl
) not in
18286 N_Generic_Package_Declaration | N_Package_Declaration
18292 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18294 -- A pragma that applies to a Ghost entity becomes Ghost for the
18295 -- purposes of legality checks and removal of ignored Ghost code.
18297 Mark_Ghost_Pragma
(N
, Pack_Id
);
18298 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18300 -- Chain the pragma on the contract for further processing by
18301 -- Analyze_Initializes_In_Decl_Part.
18303 Add_Contract_Item
(N
, Pack_Id
);
18305 -- The legality checks of pragmas Abstract_State, Initializes, and
18306 -- Initial_Condition are affected by the SPARK mode in effect. In
18307 -- addition, these three pragmas are subject to an inherent order:
18309 -- 1) Abstract_State
18311 -- 3) Initial_Condition
18313 -- Analyze all these pragmas in the order outlined above
18315 Analyze_If_Present
(Pragma_SPARK_Mode
);
18316 Analyze_If_Present
(Pragma_Abstract_State
);
18317 Analyze_If_Present
(Pragma_Initial_Condition
);
18324 -- pragma Inline ( NAME {, NAME} );
18326 when Pragma_Inline
=>
18328 -- Pragma always active unless in GNATprove mode. It is disabled
18329 -- in GNATprove mode because frontend inlining is applied
18330 -- independently of pragmas Inline and Inline_Always for
18331 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18334 if not GNATprove_Mode
then
18336 -- Inline status is Enabled if option -gnatn is specified.
18337 -- However this status determines only the value of the
18338 -- Is_Inlined flag on the subprogram and does not prevent
18339 -- the pragma itself from being recorded for later use,
18340 -- in particular for a later modification of Is_Inlined
18341 -- independently of the -gnatn option.
18343 -- In other words, if -gnatn is specified for a unit, then
18344 -- all Inline pragmas processed for the compilation of this
18345 -- unit, including those in the spec of other units, are
18346 -- activated, so subprograms will be inlined across units.
18348 -- If -gnatn is not specified, no Inline pragma is activated
18349 -- here, which means that subprograms will not be inlined
18350 -- across units. The Is_Inlined flag will nevertheless be
18351 -- set later when bodies are analyzed, so subprograms will
18352 -- be inlined within the unit.
18354 if Inline_Active
then
18355 Process_Inline
(Enabled
);
18357 Process_Inline
(Disabled
);
18361 -------------------
18362 -- Inline_Always --
18363 -------------------
18365 -- pragma Inline_Always ( NAME {, NAME} );
18367 when Pragma_Inline_Always
=>
18370 -- Pragma always active unless in CodePeer mode or GNATprove
18371 -- mode. It is disabled in CodePeer mode because inlining is
18372 -- not helpful, and enabling it caused walk order issues. It
18373 -- is disabled in GNATprove mode because frontend inlining is
18374 -- applied independently of pragmas Inline and Inline_Always for
18375 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18378 if not CodePeer_Mode
and not GNATprove_Mode
then
18379 Process_Inline
(Enabled
);
18382 --------------------
18383 -- Inline_Generic --
18384 --------------------
18386 -- pragma Inline_Generic (NAME {, NAME});
18388 when Pragma_Inline_Generic
=>
18390 Process_Generic_List
;
18392 ----------------------
18393 -- Inspection_Point --
18394 ----------------------
18396 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18398 when Pragma_Inspection_Point
=> Inspection_Point
: declare
18405 if Arg_Count
> 0 then
18408 Exp
:= Get_Pragma_Arg
(Arg
);
18411 if not Is_Entity_Name
(Exp
)
18412 or else not Is_Object
(Entity
(Exp
))
18414 Error_Pragma_Arg
("object name required", Arg
);
18418 exit when No
(Arg
);
18421 end Inspection_Point
;
18427 -- pragma Interface (
18428 -- [ Convention =>] convention_IDENTIFIER,
18429 -- [ Entity =>] LOCAL_NAME
18430 -- [, [External_Name =>] static_string_EXPRESSION ]
18431 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18433 when Pragma_Interface
=>
18438 Name_External_Name
,
18440 Check_At_Least_N_Arguments
(2);
18441 Check_At_Most_N_Arguments
(4);
18442 Process_Import_Or_Interface
;
18444 -- In Ada 2005, the permission to use Interface (a reserved word)
18445 -- as a pragma name is considered an obsolescent feature, and this
18446 -- pragma was already obsolescent in Ada 95.
18448 if Ada_Version
>= Ada_95
then
18450 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
18452 if Warn_On_Obsolescent_Feature
then
18454 ("pragma Interface is an obsolescent feature?j?", N
);
18456 ("|use pragma Import instead?j?", N
);
18460 --------------------
18461 -- Interface_Name --
18462 --------------------
18464 -- pragma Interface_Name (
18465 -- [ Entity =>] LOCAL_NAME
18466 -- [,[External_Name =>] static_string_EXPRESSION ]
18467 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18469 when Pragma_Interface_Name
=> Interface_Name
: declare
18471 Def_Id
: Entity_Id
;
18472 Hom_Id
: Entity_Id
;
18478 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
18479 Check_At_Least_N_Arguments
(2);
18480 Check_At_Most_N_Arguments
(3);
18481 Id
:= Get_Pragma_Arg
(Arg1
);
18484 -- This is obsolete from Ada 95 on, but it is an implementation
18485 -- defined pragma, so we do not consider that it violates the
18486 -- restriction (No_Obsolescent_Features).
18488 if Ada_Version
>= Ada_95
then
18489 if Warn_On_Obsolescent_Feature
then
18491 ("pragma Interface_Name is an obsolescent feature?j?", N
);
18493 ("|use pragma Import instead?j?", N
);
18497 if not Is_Entity_Name
(Id
) then
18499 ("first argument for pragma% must be entity name", Arg1
);
18500 elsif Etype
(Id
) = Any_Type
then
18503 Def_Id
:= Entity
(Id
);
18506 -- Special DEC-compatible processing for the object case, forces
18507 -- object to be imported.
18509 if Ekind
(Def_Id
) = E_Variable
then
18510 Kill_Size_Check_Code
(Def_Id
);
18511 Note_Possible_Modification
(Id
, Sure
=> False);
18513 -- Initialization is not allowed for imported variable
18515 if Present
(Expression
(Parent
(Def_Id
)))
18516 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
18518 Error_Msg_Sloc
:= Sloc
(Def_Id
);
18520 ("no initialization allowed for declaration of& #",
18524 -- For compatibility, support VADS usage of providing both
18525 -- pragmas Interface and Interface_Name to obtain the effect
18526 -- of a single Import pragma.
18528 if Is_Imported
(Def_Id
)
18529 and then Present
(First_Rep_Item
(Def_Id
))
18530 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
18531 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
18536 Set_Imported
(Def_Id
);
18539 Set_Is_Public
(Def_Id
);
18540 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18543 -- Otherwise must be subprogram
18545 elsif not Is_Subprogram
(Def_Id
) then
18547 ("argument of pragma% is not subprogram", Arg1
);
18550 Check_At_Most_N_Arguments
(3);
18554 -- Loop through homonyms
18557 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
18559 if Is_Imported
(Def_Id
) then
18560 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18564 exit when From_Aspect_Specification
(N
);
18565 Hom_Id
:= Homonym
(Hom_Id
);
18567 exit when No
(Hom_Id
)
18568 or else Scope
(Hom_Id
) /= Current_Scope
;
18573 ("argument of pragma% is not imported subprogram",
18577 end Interface_Name
;
18579 -----------------------
18580 -- Interrupt_Handler --
18581 -----------------------
18583 -- pragma Interrupt_Handler (handler_NAME);
18585 when Pragma_Interrupt_Handler
=>
18586 Check_Ada_83_Warning
;
18587 Check_Arg_Count
(1);
18588 Check_No_Identifiers
;
18590 if No_Run_Time_Mode
then
18591 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
18593 Check_Interrupt_Or_Attach_Handler
;
18594 Process_Interrupt_Or_Attach_Handler
;
18597 ------------------------
18598 -- Interrupt_Priority --
18599 ------------------------
18601 -- pragma Interrupt_Priority [(EXPRESSION)];
18603 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
18604 P
: constant Node_Id
:= Parent
(N
);
18609 Check_Ada_83_Warning
;
18611 if Arg_Count
/= 0 then
18612 Arg
:= Get_Pragma_Arg
(Arg1
);
18613 Check_Arg_Count
(1);
18614 Check_No_Identifiers
;
18616 -- The expression must be analyzed in the special manner
18617 -- described in "Handling of Default and Per-Object
18618 -- Expressions" in sem.ads.
18620 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
18623 if Nkind
(P
) not in N_Task_Definition | N_Protected_Definition
then
18628 Ent
:= Defining_Identifier
(Parent
(P
));
18630 -- Check duplicate pragma before we chain the pragma in the Rep
18631 -- Item chain of Ent.
18633 Check_Duplicate_Pragma
(Ent
);
18634 Record_Rep_Item
(Ent
, N
);
18636 -- Check the No_Task_At_Interrupt_Priority restriction
18638 if Nkind
(P
) = N_Task_Definition
then
18639 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
18642 end Interrupt_Priority
;
18644 ---------------------
18645 -- Interrupt_State --
18646 ---------------------
18648 -- pragma Interrupt_State (
18649 -- [Name =>] INTERRUPT_ID,
18650 -- [State =>] INTERRUPT_STATE);
18652 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18653 -- INTERRUPT_STATE => System | Runtime | User
18655 -- Note: if the interrupt id is given as an identifier, then it must
18656 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18657 -- given as a static integer expression which must be in the range of
18658 -- Ada.Interrupts.Interrupt_ID.
18660 when Pragma_Interrupt_State
=> Interrupt_State
: declare
18661 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
18662 -- This is the entity Ada.Interrupts.Interrupt_ID;
18664 State_Type
: Character;
18665 -- Set to 's'/'r'/'u' for System/Runtime/User
18668 -- Index to entry in Interrupt_States table
18671 -- Value of interrupt
18673 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18674 -- The first argument to the pragma
18676 Int_Ent
: Entity_Id
;
18677 -- Interrupt entity in Ada.Interrupts.Names
18681 Check_Arg_Order
((Name_Name
, Name_State
));
18682 Check_Arg_Count
(2);
18684 Check_Optional_Identifier
(Arg1
, Name_Name
);
18685 Check_Optional_Identifier
(Arg2
, Name_State
);
18686 Check_Arg_Is_Identifier
(Arg2
);
18688 -- First argument is identifier
18690 if Nkind
(Arg1X
) = N_Identifier
then
18692 -- Search list of names in Ada.Interrupts.Names
18694 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
18696 if No
(Int_Ent
) then
18697 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
18699 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
18700 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
18704 Next_Entity
(Int_Ent
);
18707 -- First argument is not an identifier, so it must be a static
18708 -- expression of type Ada.Interrupts.Interrupt_ID.
18711 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
18712 Int_Val
:= Expr_Value
(Arg1X
);
18714 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
18716 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
18719 ("value not in range of type "
18720 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
18726 case Chars
(Get_Pragma_Arg
(Arg2
)) is
18727 when Name_Runtime
=> State_Type
:= 'r';
18728 when Name_System
=> State_Type
:= 's';
18729 when Name_User
=> State_Type
:= 'u';
18732 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
18735 -- Check if entry is already stored
18737 IST_Num
:= Interrupt_States
.First
;
18739 -- If entry not found, add it
18741 if IST_Num
> Interrupt_States
.Last
then
18742 Interrupt_States
.Append
18743 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
18744 Interrupt_State
=> State_Type
,
18745 Pragma_Loc
=> Loc
));
18748 -- Case of entry for the same entry
18750 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
18753 -- If state matches, done, no need to make redundant entry
18756 State_Type
= Interrupt_States
.Table
(IST_Num
).
18759 -- Otherwise if state does not match, error
18762 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
18764 ("state conflicts with that given #", Arg2
);
18768 IST_Num
:= IST_Num
+ 1;
18770 end Interrupt_State
;
18776 -- pragma Invariant
18777 -- ([Entity =>] type_LOCAL_NAME,
18778 -- [Check =>] EXPRESSION
18779 -- [,[Message =>] String_Expression]);
18781 when Pragma_Invariant
=> Invariant
: declare
18788 Check_At_Least_N_Arguments
(2);
18789 Check_At_Most_N_Arguments
(3);
18790 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18791 Check_Optional_Identifier
(Arg2
, Name_Check
);
18793 if Arg_Count
= 3 then
18794 Check_Optional_Identifier
(Arg3
, Name_Message
);
18795 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
18798 Check_Arg_Is_Local_Name
(Arg1
);
18800 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
18801 Find_Type
(Typ_Arg
);
18802 Typ
:= Entity
(Typ_Arg
);
18804 -- Nothing to do of the related type is erroneous in some way
18806 if Typ
= Any_Type
then
18809 -- AI12-0041: Invariants are allowed in interface types
18811 elsif Is_Interface
(Typ
) then
18814 -- An invariant must apply to a private type, or appear in the
18815 -- private part of a package spec and apply to a completion.
18816 -- a class-wide invariant can only appear on a private declaration
18817 -- or private extension, not a completion.
18819 -- A [class-wide] invariant may be associated a [limited] private
18820 -- type or a private extension.
18822 elsif Ekind
(Typ
) in E_Limited_Private_Type
18824 | E_Record_Type_With_Private
18828 -- A non-class-wide invariant may be associated with the full view
18829 -- of a [limited] private type or a private extension.
18831 elsif Has_Private_Declaration
(Typ
)
18832 and then not Class_Present
(N
)
18836 -- A class-wide invariant may appear on the partial view only
18838 elsif Class_Present
(N
) then
18840 ("pragma % only allowed for private type", Arg1
);
18843 -- A regular invariant may appear on both views
18847 ("pragma % only allowed for private type or corresponding "
18848 & "full view", Arg1
);
18852 -- An invariant associated with an abstract type (this includes
18853 -- interfaces) must be class-wide.
18855 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18857 ("pragma % not allowed for abstract type", Arg1
);
18861 -- A pragma that applies to a Ghost entity becomes Ghost for the
18862 -- purposes of legality checks and removal of ignored Ghost code.
18864 Mark_Ghost_Pragma
(N
, Typ
);
18866 -- The pragma defines a type-specific invariant, the type is said
18867 -- to have invariants of its "own".
18869 Set_Has_Own_Invariants
(Base_Type
(Typ
));
18871 -- If the invariant is class-wide, then it can be inherited by
18872 -- derived or interface implementing types. The type is said to
18873 -- have "inheritable" invariants.
18875 if Class_Present
(N
) then
18876 Set_Has_Inheritable_Invariants
(Typ
);
18879 -- Chain the pragma on to the rep item chain, for processing when
18880 -- the type is frozen.
18882 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18884 -- Create the declaration of the invariant procedure that will
18885 -- verify the invariant at run time. Interfaces are treated as the
18886 -- partial view of a private type in order to achieve uniformity
18887 -- with the general case. As a result, an interface receives only
18888 -- a "partial" invariant procedure, which is never called.
18890 Build_Invariant_Procedure_Declaration
18892 Partial_Invariant
=> Is_Interface
(Typ
));
18899 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18901 when Pragma_Keep_Names
=> Keep_Names
: declare
18906 Check_Arg_Count
(1);
18907 Check_Optional_Identifier
(Arg1
, Name_On
);
18908 Check_Arg_Is_Local_Name
(Arg1
);
18910 Arg
:= Get_Pragma_Arg
(Arg1
);
18913 if Etype
(Arg
) = Any_Type
then
18917 if not Is_Entity_Name
(Arg
)
18918 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18921 ("pragma% requires a local enumeration type", Arg1
);
18924 Set_Discard_Names
(Entity
(Arg
), False);
18931 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18933 when Pragma_License
=>
18936 -- Do not analyze pragma any further in CodePeer mode, to avoid
18937 -- extraneous errors in this implementation-dependent pragma,
18938 -- which has a different profile on other compilers.
18940 if CodePeer_Mode
then
18944 Check_Arg_Count
(1);
18945 Check_No_Identifiers
;
18946 Check_Valid_Configuration_Pragma
;
18947 Check_Arg_Is_Identifier
(Arg1
);
18950 Sind
: constant Source_File_Index
:=
18951 Source_Index
(Current_Sem_Unit
);
18954 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18956 Set_License
(Sind
, GPL
);
18958 when Name_Modified_GPL
=>
18959 Set_License
(Sind
, Modified_GPL
);
18961 when Name_Restricted
=>
18962 Set_License
(Sind
, Restricted
);
18964 when Name_Unrestricted
=>
18965 Set_License
(Sind
, Unrestricted
);
18968 Error_Pragma_Arg
("invalid license name", Arg1
);
18976 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18978 when Pragma_Link_With
=> Link_With
: declare
18984 if Operating_Mode
= Generate_Code
18985 and then In_Extended_Main_Source_Unit
(N
)
18987 Check_At_Least_N_Arguments
(1);
18988 Check_No_Identifiers
;
18989 Check_Is_In_Decl_Part_Or_Package_Spec
;
18990 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18994 while Present
(Arg
) loop
18995 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18997 -- Store argument, converting sequences of spaces to a
18998 -- single null character (this is one of the differences
18999 -- in processing between Link_With and Linker_Options).
19001 Arg_Store
: declare
19002 C
: constant Char_Code
:= Get_Char_Code
(' ');
19003 S
: constant String_Id
:=
19004 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
19005 L
: constant Nat
:= String_Length
(S
);
19008 procedure Skip_Spaces
;
19009 -- Advance F past any spaces
19015 procedure Skip_Spaces
is
19017 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
19022 -- Start of processing for Arg_Store
19025 Skip_Spaces
; -- skip leading spaces
19027 -- Loop through characters, changing any embedded
19028 -- sequence of spaces to a single null character (this
19029 -- is how Link_With/Linker_Options differ)
19032 if Get_String_Char
(S
, F
) = C
then
19035 Store_String_Char
(ASCII
.NUL
);
19038 Store_String_Char
(Get_String_Char
(S
, F
));
19046 if Present
(Arg
) then
19047 Store_String_Char
(ASCII
.NUL
);
19051 Store_Linker_Option_String
(End_String
);
19059 -- pragma Linker_Alias (
19060 -- [Entity =>] LOCAL_NAME
19061 -- [Target =>] static_string_EXPRESSION);
19063 when Pragma_Linker_Alias
=>
19065 Check_Arg_Order
((Name_Entity
, Name_Target
));
19066 Check_Arg_Count
(2);
19067 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19068 Check_Optional_Identifier
(Arg2
, Name_Target
);
19069 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19070 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19072 -- The only processing required is to link this item on to the
19073 -- list of rep items for the given entity. This is accomplished
19074 -- by the call to Rep_Item_Too_Late (when no error is detected
19075 -- and False is returned).
19077 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
19080 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19083 ------------------------
19084 -- Linker_Constructor --
19085 ------------------------
19087 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
19089 -- Code is shared with Linker_Destructor
19091 -----------------------
19092 -- Linker_Destructor --
19093 -----------------------
19095 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
19097 when Pragma_Linker_Constructor
19098 | Pragma_Linker_Destructor
19100 Linker_Constructor
: declare
19106 Check_Arg_Count
(1);
19107 Check_No_Identifiers
;
19108 Check_Arg_Is_Local_Name
(Arg1
);
19109 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
19111 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
19113 if not Is_Library_Level_Entity
(Proc
) then
19115 ("argument for pragma% must be library level entity", Arg1
);
19118 -- The only processing required is to link this item on to the
19119 -- list of rep items for the given entity. This is accomplished
19120 -- by the call to Rep_Item_Too_Late (when no error is detected
19121 -- and False is returned).
19123 if Rep_Item_Too_Late
(Proc
, N
) then
19126 Set_Has_Gigi_Rep_Item
(Proc
);
19128 end Linker_Constructor
;
19130 --------------------
19131 -- Linker_Options --
19132 --------------------
19134 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
19136 when Pragma_Linker_Options
=> Linker_Options
: declare
19140 Check_Ada_83_Warning
;
19141 Check_No_Identifiers
;
19142 Check_Arg_Count
(1);
19143 Check_Is_In_Decl_Part_Or_Package_Spec
;
19144 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19145 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
19148 while Present
(Arg
) loop
19149 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19150 Store_String_Char
(ASCII
.NUL
);
19152 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19156 if Operating_Mode
= Generate_Code
19157 and then In_Extended_Main_Source_Unit
(N
)
19159 Store_Linker_Option_String
(End_String
);
19161 end Linker_Options
;
19163 --------------------
19164 -- Linker_Section --
19165 --------------------
19167 -- pragma Linker_Section (
19168 -- [Entity =>] LOCAL_NAME
19169 -- [Section =>] static_string_EXPRESSION);
19171 when Pragma_Linker_Section
=> Linker_Section
: declare
19176 Ghost_Error_Posted
: Boolean := False;
19177 -- Flag set when an error concerning the illegal mix of Ghost and
19178 -- non-Ghost subprograms is emitted.
19180 Ghost_Id
: Entity_Id
:= Empty
;
19181 -- The entity of the first Ghost subprogram encountered while
19182 -- processing the arguments of the pragma.
19186 Check_Arg_Order
((Name_Entity
, Name_Section
));
19187 Check_Arg_Count
(2);
19188 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19189 Check_Optional_Identifier
(Arg2
, Name_Section
);
19190 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19191 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19193 -- Check kind of entity
19195 Arg
:= Get_Pragma_Arg
(Arg1
);
19196 Ent
:= Entity
(Arg
);
19198 case Ekind
(Ent
) is
19200 -- Objects (constants and variables) and types. For these cases
19201 -- all we need to do is to set the Linker_Section_pragma field,
19202 -- checking that we do not have a duplicate.
19208 LPE
:= Linker_Section_Pragma
(Ent
);
19210 if Present
(LPE
) then
19211 Error_Msg_Sloc
:= Sloc
(LPE
);
19213 ("Linker_Section already specified for &#", Arg1
, Ent
);
19216 Set_Linker_Section_Pragma
(Ent
, N
);
19218 -- A pragma that applies to a Ghost entity becomes Ghost for
19219 -- the purposes of legality checks and removal of ignored
19222 Mark_Ghost_Pragma
(N
, Ent
);
19226 when Subprogram_Kind
=>
19228 -- Aspect case, entity already set
19230 if From_Aspect_Specification
(N
) then
19231 Set_Linker_Section_Pragma
19232 (Entity
(Corresponding_Aspect
(N
)), N
);
19234 -- Propagate it to its ultimate aliased entity to
19235 -- facilitate the backend processing this attribute
19236 -- in instantiations of generic subprograms.
19238 if Present
(Alias
(Entity
(Corresponding_Aspect
(N
))))
19240 Set_Linker_Section_Pragma
19242 (Entity
(Corresponding_Aspect
(N
))), N
);
19245 -- Pragma case, we must climb the homonym chain, but skip
19246 -- any for which the linker section is already set.
19250 if No
(Linker_Section_Pragma
(Ent
)) then
19251 Set_Linker_Section_Pragma
(Ent
, N
);
19253 -- Propagate it to its ultimate aliased entity to
19254 -- facilitate the backend processing this attribute
19255 -- in instantiations of generic subprograms.
19257 if Present
(Alias
(Ent
)) then
19258 Set_Linker_Section_Pragma
19259 (Ultimate_Alias
(Ent
), N
);
19262 -- A pragma that applies to a Ghost entity becomes
19263 -- Ghost for the purposes of legality checks and
19264 -- removal of ignored Ghost code.
19266 Mark_Ghost_Pragma
(N
, Ent
);
19268 -- Capture the entity of the first Ghost subprogram
19269 -- being processed for error detection purposes.
19271 if Is_Ghost_Entity
(Ent
) then
19272 if No
(Ghost_Id
) then
19276 -- Otherwise the subprogram is non-Ghost. It is
19277 -- illegal to mix references to Ghost and non-Ghost
19278 -- entities (SPARK RM 6.9).
19280 elsif Present
(Ghost_Id
)
19281 and then not Ghost_Error_Posted
19283 Ghost_Error_Posted
:= True;
19285 Error_Msg_Name_1
:= Pname
;
19287 ("pragma % cannot mention ghost and "
19288 & "non-ghost subprograms", N
);
19290 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19292 ("\& # declared as ghost", N
, Ghost_Id
);
19294 Error_Msg_Sloc
:= Sloc
(Ent
);
19296 ("\& # declared as non-ghost", N
, Ent
);
19300 Ent
:= Homonym
(Ent
);
19302 or else Scope
(Ent
) /= Current_Scope
;
19306 -- All other cases are illegal
19310 ("pragma% applies only to objects, subprograms, and types",
19313 end Linker_Section
;
19319 -- pragma List (On | Off)
19321 -- There is nothing to do here, since we did all the processing for
19322 -- this pragma in Par.Prag (so that it works properly even in syntax
19325 when Pragma_List
=>
19332 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19334 when Pragma_Lock_Free
=> Lock_Free
: declare
19335 P
: constant Node_Id
:= Parent
(N
);
19341 Check_No_Identifiers
;
19342 Check_At_Most_N_Arguments
(1);
19344 -- Protected definition case
19346 if Nkind
(P
) = N_Protected_Definition
then
19347 Ent
:= Defining_Identifier
(Parent
(P
));
19351 if Arg_Count
= 1 then
19352 Arg
:= Get_Pragma_Arg
(Arg1
);
19353 Val
:= Is_True
(Static_Boolean
(Arg
));
19355 -- No arguments (expression is considered to be True)
19361 -- Check duplicate pragma before we chain the pragma in the Rep
19362 -- Item chain of Ent.
19364 Check_Duplicate_Pragma
(Ent
);
19365 Record_Rep_Item
(Ent
, N
);
19366 Set_Uses_Lock_Free
(Ent
, Val
);
19368 -- Anything else is incorrect placement
19375 --------------------
19376 -- Locking_Policy --
19377 --------------------
19379 -- pragma Locking_Policy (policy_IDENTIFIER);
19381 when Pragma_Locking_Policy
=> declare
19382 subtype LP_Range
is Name_Id
19383 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
19388 Check_Ada_83_Warning
;
19389 Check_Arg_Count
(1);
19390 Check_No_Identifiers
;
19391 Check_Arg_Is_Locking_Policy
(Arg1
);
19392 Check_Valid_Configuration_Pragma
;
19393 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19396 when Name_Ceiling_Locking
=> LP
:= 'C';
19397 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
19398 when Name_Inheritance_Locking
=> LP
:= 'I';
19401 if Locking_Policy
/= ' '
19402 and then Locking_Policy
/= LP
19404 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19405 Error_Pragma
("locking policy incompatible with policy#");
19407 -- Set new policy, but always preserve System_Location since we
19408 -- like the error message with the run time name.
19411 Locking_Policy
:= LP
;
19413 if Locking_Policy_Sloc
/= System_Location
then
19414 Locking_Policy_Sloc
:= Loc
;
19419 -------------------
19420 -- Loop_Optimize --
19421 -------------------
19423 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19425 -- OPTIMIZATION_HINT ::=
19426 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19428 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
19433 Check_At_Least_N_Arguments
(1);
19434 Check_No_Identifiers
;
19436 Hint
:= First
(Pragma_Argument_Associations
(N
));
19437 while Present
(Hint
) loop
19438 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
19446 Check_Loop_Pragma_Placement
;
19453 -- pragma Loop_Variant
19454 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19456 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19458 -- CHANGE_DIRECTION ::= Increases | Decreases
19460 when Pragma_Loop_Variant
=> Loop_Variant
: declare
19465 Check_At_Least_N_Arguments
(1);
19466 Check_Loop_Pragma_Placement
;
19468 -- Process all increasing / decreasing expressions
19470 Variant
:= First
(Pragma_Argument_Associations
(N
));
19471 while Present
(Variant
) loop
19472 if Chars
(Variant
) = No_Name
then
19473 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
19475 elsif Chars
(Variant
) not in Name_Decreases | Name_Increases
19478 Name
: String := Get_Name_String
(Chars
(Variant
));
19481 -- It is a common mistake to write "Increasing" for
19482 -- "Increases" or "Decreasing" for "Decreases". Recognize
19483 -- specially names starting with "incr" or "decr" to
19484 -- suggest the corresponding name.
19486 System
.Case_Util
.To_Lower
(Name
);
19488 if Name
'Length >= 4
19489 and then Name
(1 .. 4) = "incr"
19491 Error_Pragma_Arg_Ident
19492 ("expect name `Increases`", Variant
);
19494 elsif Name
'Length >= 4
19495 and then Name
(1 .. 4) = "decr"
19497 Error_Pragma_Arg_Ident
19498 ("expect name `Decreases`", Variant
);
19501 Error_Pragma_Arg_Ident
19502 ("expect name `Increases` or `Decreases`", Variant
);
19507 Preanalyze_Assert_Expression
19508 (Expression
(Variant
), Any_Discrete
);
19514 -----------------------
19515 -- Machine_Attribute --
19516 -----------------------
19518 -- pragma Machine_Attribute (
19519 -- [Entity =>] LOCAL_NAME,
19520 -- [Attribute_Name =>] static_string_EXPRESSION
19521 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] );
19523 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
19525 Def_Id
: Entity_Id
;
19529 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
19531 if Arg_Count
>= 3 then
19532 Check_Optional_Identifier
(Arg3
, Name_Info
);
19534 while Present
(Arg
) loop
19535 Check_Arg_Is_OK_Static_Expression
(Arg
);
19539 Check_Arg_Count
(2);
19542 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19543 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
19544 Check_Arg_Is_Local_Name
(Arg1
);
19545 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19546 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
19548 -- Apply the pragma to the designated type, rather than to the
19549 -- access type, unless it's a strub annotation. We wish to enable
19550 -- objects of access type, as well as access types themselves, to
19551 -- be annotated, so that reading the access objects (as oposed to
19552 -- the designated data) automatically enables stack
19553 -- scrubbing. That said, as in the attribute handler that
19554 -- processes the pragma turned into a compiler attribute, a strub
19555 -- annotation that must be associated with a subprogram type (for
19556 -- holding an explicit strub mode), when applied to an
19557 -- access-to-subprogram, gets promoted to the subprogram type. We
19558 -- might be tempted to leave it alone here, since the C attribute
19559 -- handler will adjust it, but then GNAT would convert the
19560 -- annotated subprogram types to naked ones before using them,
19561 -- cancelling out their intended effects.
19563 if Is_Access_Type
(Def_Id
)
19564 and then (not Strub_Pragma_P
(N
)
19568 Ekind
(Designated_Type
19569 (Def_Id
)) = E_Subprogram_Type
))
19571 Def_Id
:= Designated_Type
(Def_Id
);
19574 if Rep_Item_Too_Early
(Def_Id
, N
) then
19578 Def_Id
:= Underlying_Type
(Def_Id
);
19580 -- The only processing required is to link this item on to the
19581 -- list of rep items for the given entity. This is accomplished
19582 -- by the call to Rep_Item_Too_Late (when no error is detected
19583 -- and False is returned).
19585 if Rep_Item_Too_Late
(Def_Id
, N
) then
19588 Set_Has_Gigi_Rep_Item
(Def_Id
);
19590 end Machine_Attribute
;
19597 -- (MAIN_OPTION [, MAIN_OPTION]);
19600 -- [STACK_SIZE =>] static_integer_EXPRESSION
19601 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19602 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19604 when Pragma_Main
=> Main
: declare
19605 Args
: Args_List
(1 .. 3);
19606 Names
: constant Name_List
(1 .. 3) := (
19608 Name_Task_Stack_Size_Default
,
19609 Name_Time_Slicing_Enabled
);
19615 Gather_Associations
(Names
, Args
);
19617 for J
in 1 .. 2 loop
19618 if Present
(Args
(J
)) then
19619 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19623 if Present
(Args
(3)) then
19624 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
19628 while Present
(Nod
) loop
19629 if Nkind
(Nod
) = N_Pragma
19630 and then Pragma_Name
(Nod
) = Name_Main
19632 Error_Msg_Name_1
:= Pname
;
19633 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19644 -- pragma Main_Storage
19645 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19647 -- MAIN_STORAGE_OPTION ::=
19648 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19649 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19651 when Pragma_Main_Storage
=> Main_Storage
: declare
19652 Args
: Args_List
(1 .. 2);
19653 Names
: constant Name_List
(1 .. 2) := (
19654 Name_Working_Storage
,
19661 Gather_Associations
(Names
, Args
);
19663 for J
in 1 .. 2 loop
19664 if Present
(Args
(J
)) then
19665 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19669 Check_In_Main_Program
;
19672 while Present
(Nod
) loop
19673 if Nkind
(Nod
) = N_Pragma
19674 and then Pragma_Name
(Nod
) = Name_Main_Storage
19676 Error_Msg_Name_1
:= Pname
;
19677 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19684 ----------------------------
19685 -- Max_Entry_Queue_Length --
19686 ----------------------------
19688 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION);
19690 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and
19691 -- Pragma_Max_Queue_Length.
19693 when Pragma_Max_Entry_Queue_Length
19694 | Pragma_Max_Entry_Queue_Depth
19695 | Pragma_Max_Queue_Length
19697 Max_Entry_Queue_Length
: declare
19699 Entry_Decl
: Node_Id
;
19700 Entry_Id
: Entity_Id
;
19704 if Prag_Id
= Pragma_Max_Entry_Queue_Depth
19705 or else Prag_Id
= Pragma_Max_Queue_Length
19710 Check_Arg_Count
(1);
19713 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
19715 -- Entry declaration
19717 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
19719 -- Entry illegally within a task
19721 if Nkind
(Parent
(N
)) = N_Task_Definition
then
19722 Error_Pragma
("pragma % cannot apply to task entries");
19726 Entry_Id
:= Defining_Entity
(Entry_Decl
);
19728 -- Otherwise the pragma is associated with an illegal construct
19732 ("pragma % must apply to a protected entry declaration");
19736 -- Mark the pragma as Ghost if the related subprogram is also
19737 -- Ghost. This also ensures that any expansion performed further
19738 -- below will produce Ghost nodes.
19740 Mark_Ghost_Pragma
(N
, Entry_Id
);
19742 -- Analyze the Integer expression
19744 Arg
:= Get_Pragma_Arg
(Arg1
);
19745 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
19747 Val
:= Expr_Value
(Arg
);
19751 ("argument for pragma% cannot be less than -1", Arg1
);
19753 elsif not UI_Is_In_Int_Range
(Val
) then
19755 ("argument for pragma% out of range of Integer", Arg1
);
19759 Record_Rep_Item
(Entry_Id
, N
);
19760 end Max_Entry_Queue_Length
;
19766 -- pragma Memory_Size (NUMERIC_LITERAL)
19768 when Pragma_Memory_Size
=>
19771 -- Memory size is simply ignored
19773 Check_No_Identifiers
;
19774 Check_Arg_Count
(1);
19775 Check_Arg_Is_Integer_Literal
(Arg1
);
19783 -- The only correct use of this pragma is on its own in a file, in
19784 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19785 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19786 -- check for a file containing nothing but a No_Body pragma). If we
19787 -- attempt to process it during normal semantics processing, it means
19788 -- it was misplaced.
19790 when Pragma_No_Body
=>
19794 -----------------------------
19795 -- No_Elaboration_Code_All --
19796 -----------------------------
19798 -- pragma No_Elaboration_Code_All;
19800 when Pragma_No_Elaboration_Code_All
=>
19802 Check_Valid_Library_Unit_Pragma
;
19804 -- If N was rewritten as a null statement there is nothing more
19807 if Nkind
(N
) = N_Null_Statement
then
19811 -- Must appear for a spec or generic spec
19813 if Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) not in
19814 N_Generic_Package_Declaration |
19815 N_Generic_Subprogram_Declaration |
19816 N_Package_Declaration |
19817 N_Subprogram_Declaration
19821 ("pragma% can only occur for package "
19822 & "or subprogram spec"));
19825 -- Set flag in unit table
19827 Set_No_Elab_Code_All
(Current_Sem_Unit
);
19829 -- Set restriction No_Elaboration_Code if this is the main unit
19831 if Current_Sem_Unit
= Main_Unit
then
19832 Set_Restriction
(No_Elaboration_Code
, N
);
19835 -- If we are in the main unit or in an extended main source unit,
19836 -- then we also add it to the configuration restrictions so that
19837 -- it will apply to all units in the extended main source.
19839 if Current_Sem_Unit
= Main_Unit
19840 or else In_Extended_Main_Source_Unit
(N
)
19842 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
19845 -- If in main extended unit, activate transitive with test
19847 if In_Extended_Main_Source_Unit
(N
) then
19848 Opt
.No_Elab_Code_All_Pragma
:= N
;
19851 -----------------------------
19852 -- No_Component_Reordering --
19853 -----------------------------
19855 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19857 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
19863 Check_At_Most_N_Arguments
(1);
19865 if Arg_Count
= 0 then
19866 Check_Valid_Configuration_Pragma
;
19867 Opt
.No_Component_Reordering
:= True;
19870 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19871 Check_Arg_Is_Local_Name
(Arg1
);
19872 E_Id
:= Get_Pragma_Arg
(Arg1
);
19874 if Etype
(E_Id
) = Any_Type
then
19878 E
:= Entity
(E_Id
);
19880 if not Is_Record_Type
(E
) then
19881 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
19884 Set_No_Reordering
(Base_Type
(E
));
19886 end No_Comp_Reordering
;
19888 --------------------------
19889 -- No_Heap_Finalization --
19890 --------------------------
19892 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19894 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
19895 Context
: constant Node_Id
:= Parent
(N
);
19896 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19902 Check_No_Identifiers
;
19904 -- The pragma appears in a configuration file
19906 if No
(Context
) then
19907 Check_Arg_Count
(0);
19908 Check_Valid_Configuration_Pragma
;
19910 -- Detect a duplicate pragma
19912 if Present
(No_Heap_Finalization_Pragma
) then
19915 Prev
=> No_Heap_Finalization_Pragma
);
19919 No_Heap_Finalization_Pragma
:= N
;
19921 -- Otherwise the pragma should be associated with a library-level
19922 -- named access-to-object type.
19925 Check_Arg_Count
(1);
19926 Check_Arg_Is_Local_Name
(Arg1
);
19928 Find_Type
(Typ_Arg
);
19929 Typ
:= Entity
(Typ_Arg
);
19931 -- The type being subjected to the pragma is erroneous
19933 if Typ
= Any_Type
then
19934 Error_Pragma
("cannot find type referenced by pragma %");
19936 -- The pragma is applied to an incomplete or generic formal
19937 -- type way too early.
19939 elsif Rep_Item_Too_Early
(Typ
, N
) then
19943 Typ
:= Underlying_Type
(Typ
);
19946 -- The pragma must apply to an access-to-object type
19948 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
then
19951 -- Give a detailed error message on all other access type kinds
19953 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19955 ("pragma % cannot apply to access protected subprogram "
19958 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19960 ("pragma % cannot apply to access subprogram type");
19962 elsif Is_Anonymous_Access_Type
(Typ
) then
19964 ("pragma % cannot apply to anonymous access type");
19966 -- Give a general error message in case the pragma applies to a
19967 -- non-access type.
19971 ("pragma % must apply to library level access type");
19974 -- At this point the argument denotes an access-to-object type.
19975 -- Ensure that the type is declared at the library level.
19977 if Is_Library_Level_Entity
(Typ
) then
19980 -- Quietly ignore an access-to-object type originally declared
19981 -- at the library level within a generic, but instantiated at
19982 -- a non-library level. As a result the access-to-object type
19983 -- "loses" its No_Heap_Finalization property.
19985 elsif In_Instance
then
19990 ("pragma % must apply to library level access type");
19993 -- Detect a duplicate pragma
19995 if Present
(No_Heap_Finalization_Pragma
) then
19998 Prev
=> No_Heap_Finalization_Pragma
);
20002 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
20004 if Present
(Prev
) then
20012 Record_Rep_Item
(Typ
, N
);
20014 end No_Heap_Finalization
;
20020 -- pragma No_Inline ( NAME {, NAME} );
20022 when Pragma_No_Inline
=>
20024 Process_Inline
(Suppressed
);
20030 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
20032 when Pragma_No_Return
=> Prag_No_Return
: declare
20034 function Check_No_Return
20036 N
: Node_Id
) return Boolean;
20037 -- Check rule 6.5.1(4/3) of the Ada RM. If the rule is violated,
20038 -- emit an error message and return False, otherwise return True.
20039 -- 6.5.1 Nonreturning procedures:
20040 -- 4/3 "Aspect No_Return shall not be specified for a null
20041 -- procedure nor an instance of a generic unit."
20043 ---------------------
20044 -- Check_No_Return --
20045 ---------------------
20047 function Check_No_Return
20049 N
: Node_Id
) return Boolean
20052 if Ekind
(E
) = E_Procedure
then
20054 -- If E is a generic instance, marking it with No_Return
20055 -- is forbidden, but having it inherit the No_Return of
20056 -- the generic is allowed. We check if E is inheriting its
20057 -- No_Return flag from the generic by checking if No_Return
20060 if Is_Generic_Instance
(E
) and then not No_Return
(E
) then
20062 ("generic instance & is marked as No_Return", N
, E
);
20064 ("\generic procedure & must be marked No_Return",
20066 Generic_Parent
(Parent
(E
)));
20069 elsif Null_Present
(Subprogram_Specification
(E
)) then
20071 ("null procedure & cannot be marked No_Return", N
, E
);
20077 end Check_No_Return
;
20084 Ghost_Error_Posted
: Boolean := False;
20085 -- Flag set when an error concerning the illegal mix of Ghost and
20086 -- non-Ghost subprograms is emitted.
20088 Ghost_Id
: Entity_Id
:= Empty
;
20089 -- The entity of the first Ghost procedure encountered while
20090 -- processing the arguments of the pragma.
20094 Check_At_Least_N_Arguments
(1);
20096 -- Loop through arguments of pragma
20099 while Present
(Arg
) loop
20100 Check_Arg_Is_Local_Name
(Arg
);
20101 Id
:= Get_Pragma_Arg
(Arg
);
20104 if not Is_Entity_Name
(Id
) then
20105 Error_Pragma_Arg
("entity name required", Arg
);
20108 if Etype
(Id
) = Any_Type
then
20112 -- Loop to find matching procedures or functions (Ada 2022)
20118 and then Scope
(E
) = Current_Scope
20120 -- Ada 2022 (AI12-0269): A function can be No_Return
20122 if Ekind
(E
) in E_Generic_Procedure | E_Procedure
20123 or else (Ada_Version
>= Ada_2022
20125 Ekind
(E
) in E_Generic_Function | E_Function
)
20127 -- Check that the pragma is not applied to a body.
20128 -- First check the specless body case, to give a
20129 -- different error message. These checks do not apply
20130 -- if Relaxed_RM_Semantics, to accommodate other Ada
20131 -- compilers. Disable these checks under -gnatd.J.
20133 if not Debug_Flag_Dot_JJ
then
20134 if Nkind
(Parent
(Declaration_Node
(E
))) =
20136 and then not Relaxed_RM_Semantics
20139 ("pragma% requires separate spec and must come "
20143 -- Now the "specful" body case
20145 if Rep_Item_Too_Late
(E
, N
) then
20150 if Check_No_Return
(E
, N
) then
20154 -- A pragma that applies to a Ghost entity becomes Ghost
20155 -- for the purposes of legality checks and removal of
20156 -- ignored Ghost code.
20158 Mark_Ghost_Pragma
(N
, E
);
20160 -- Capture the entity of the first Ghost procedure being
20161 -- processed for error detection purposes.
20163 if Is_Ghost_Entity
(E
) then
20164 if No
(Ghost_Id
) then
20168 -- Otherwise the subprogram is non-Ghost. It is illegal
20169 -- to mix references to Ghost and non-Ghost entities
20172 elsif Present
(Ghost_Id
)
20173 and then not Ghost_Error_Posted
20175 Ghost_Error_Posted
:= True;
20177 Error_Msg_Name_1
:= Pname
;
20179 ("pragma % cannot mention ghost and non-ghost "
20180 & "procedures", N
);
20182 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
20183 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
20185 Error_Msg_Sloc
:= Sloc
(E
);
20186 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
20189 -- Set flag on any alias as well
20191 if Is_Overloadable
(E
)
20192 and then Present
(Alias
(E
))
20193 and then Check_No_Return
(Alias
(E
), N
)
20195 Set_No_Return
(Alias
(E
));
20201 exit when From_Aspect_Specification
(N
);
20205 -- If entity in not in current scope it may be the enclosing
20206 -- suprogram body to which the aspect applies.
20209 if Entity
(Id
) = Current_Scope
20210 and then From_Aspect_Specification
(N
)
20211 and then Check_No_Return
(Entity
(Id
), N
)
20213 Set_No_Return
(Entity
(Id
));
20215 elsif Ada_Version
>= Ada_2022
then
20217 ("no subprogram& found for pragma%", Arg
);
20220 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
20226 end Prag_No_Return
;
20232 -- pragma No_Run_Time;
20234 -- Note: this pragma is retained for backwards compatibility. See
20235 -- body of Rtsfind for full details on its handling.
20237 when Pragma_No_Run_Time
=>
20239 Check_Valid_Configuration_Pragma
;
20240 Check_Arg_Count
(0);
20242 -- Remove backward compatibility if Build_Type is FSF or GPL and
20243 -- generate a warning.
20246 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
20249 Error_Pragma
("pragma% is ignored, has no effect??");
20251 No_Run_Time_Mode
:= True;
20252 Configurable_Run_Time_Mode
:= True;
20254 -- Set Duration to 32 bits if word size is 32
20256 if Ttypes
.System_Word_Size
= 32 then
20257 Duration_32_Bits_On_Target
:= True;
20260 -- Set appropriate restrictions
20262 Set_Restriction
(No_Finalization
, N
);
20263 Set_Restriction
(No_Exception_Handlers
, N
);
20264 Set_Restriction
(Max_Tasks
, N
, 0);
20265 Set_Restriction
(No_Tasking
, N
);
20269 -----------------------
20270 -- No_Tagged_Streams --
20271 -----------------------
20273 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20275 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20281 Check_At_Most_N_Arguments
(1);
20283 -- One argument case
20285 if Arg_Count
= 1 then
20286 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20287 Check_Arg_Is_Local_Name
(Arg1
);
20288 E_Id
:= Get_Pragma_Arg
(Arg1
);
20290 if Etype
(E_Id
) = Any_Type
then
20294 E
:= Entity
(E_Id
);
20296 Check_Duplicate_Pragma
(E
);
20298 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20300 ("argument for pragma% must be root tagged type", Arg1
);
20303 if Rep_Item_Too_Early
(E
, N
)
20305 Rep_Item_Too_Late
(E
, N
)
20309 Set_No_Tagged_Streams_Pragma
(E
, N
);
20312 -- Zero argument case
20315 Check_Is_In_Decl_Part_Or_Package_Spec
;
20316 No_Tagged_Streams
:= N
;
20318 end No_Tagged_Strms
;
20320 ------------------------
20321 -- No_Strict_Aliasing --
20322 ------------------------
20324 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20326 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20332 Check_At_Most_N_Arguments
(1);
20334 if Arg_Count
= 0 then
20335 Check_Valid_Configuration_Pragma
;
20336 Opt
.No_Strict_Aliasing
:= True;
20339 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20340 Check_Arg_Is_Local_Name
(Arg1
);
20341 E_Id
:= Get_Pragma_Arg
(Arg1
);
20343 if Etype
(E_Id
) = Any_Type
then
20347 E
:= Entity
(E_Id
);
20349 if not Is_Access_Type
(E
) then
20350 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
20353 Set_No_Strict_Aliasing
(Base_Type
(E
));
20355 end No_Strict_Aliasing
;
20357 -----------------------
20358 -- Normalize_Scalars --
20359 -----------------------
20361 -- pragma Normalize_Scalars;
20363 when Pragma_Normalize_Scalars
=>
20364 Check_Ada_83_Warning
;
20365 Check_Arg_Count
(0);
20366 Check_Valid_Configuration_Pragma
;
20368 -- Normalize_Scalars creates false positives in CodePeer, and
20369 -- incorrect negative results in GNATprove mode, so ignore this
20370 -- pragma in these modes.
20372 if not (CodePeer_Mode
or GNATprove_Mode
) then
20373 Normalize_Scalars
:= True;
20374 Init_Or_Norm_Scalars
:= True;
20381 -- pragma Obsolescent;
20383 -- pragma Obsolescent (
20384 -- [Message =>] static_string_EXPRESSION
20385 -- [,[Version =>] Ada_05]]);
20387 -- pragma Obsolescent (
20388 -- [Entity =>] NAME
20389 -- [,[Message =>] static_string_EXPRESSION
20390 -- [,[Version =>] Ada_05]] );
20392 when Pragma_Obsolescent
=> Obsolescent
: declare
20396 procedure Set_Obsolescent
(E
: Entity_Id
);
20397 -- Given an entity Ent, mark it as obsolescent if appropriate
20399 ---------------------
20400 -- Set_Obsolescent --
20401 ---------------------
20403 procedure Set_Obsolescent
(E
: Entity_Id
) is
20412 -- A pragma that applies to a Ghost entity becomes Ghost for
20413 -- the purposes of legality checks and removal of ignored Ghost
20416 Mark_Ghost_Pragma
(N
, E
);
20418 -- Entity name was given
20420 if Present
(Ename
) then
20422 -- If entity name matches, we are fine.
20424 if Chars
(Ename
) = Chars
(Ent
) then
20425 Set_Entity
(Ename
, Ent
);
20426 Generate_Reference
(Ent
, Ename
);
20428 -- If entity name does not match, only possibility is an
20429 -- enumeration literal from an enumeration type declaration.
20431 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
20433 ("pragma % entity name does not match declaration");
20436 Ent
:= First_Literal
(E
);
20440 ("pragma % entity name does not match any "
20441 & "enumeration literal");
20443 elsif Chars
(Ent
) = Chars
(Ename
) then
20444 Set_Entity
(Ename
, Ent
);
20445 Generate_Reference
(Ent
, Ename
);
20449 Next_Literal
(Ent
);
20455 -- Ent points to entity to be marked
20457 if Arg_Count
>= 1 then
20459 -- Deal with static string argument
20461 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20462 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
20464 for J
in 1 .. String_Length
(S
) loop
20465 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
20467 ("pragma% argument does not allow wide characters",
20472 Obsolescent_Warnings
.Append
20473 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
20475 -- Check for Ada_05 parameter
20477 if Arg_Count
/= 1 then
20478 Check_Arg_Count
(2);
20481 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20484 Check_Arg_Is_Identifier
(Argx
);
20486 if Chars
(Argx
) /= Name_Ada_05
then
20487 Error_Msg_Name_2
:= Name_Ada_05
;
20489 ("only allowed argument for pragma% is %", Argx
);
20492 if Ada_Version_Explicit
< Ada_2005
20493 or else not Warn_On_Ada_2005_Compatibility
20501 -- Set flag if pragma active
20504 Set_Is_Obsolescent
(Ent
);
20508 end Set_Obsolescent
;
20510 -- Start of processing for pragma Obsolescent
20515 Check_At_Most_N_Arguments
(3);
20517 -- See if first argument specifies an entity name
20521 (Chars
(Arg1
) = Name_Entity
20523 Nkind
(Get_Pragma_Arg
(Arg1
)) in
20524 N_Character_Literal | N_Identifier | N_Operator_Symbol
)
20526 Ename
:= Get_Pragma_Arg
(Arg1
);
20528 -- Eliminate first argument, so we can share processing
20532 Arg_Count
:= Arg_Count
- 1;
20534 -- No Entity name argument given
20540 if Arg_Count
>= 1 then
20541 Check_Optional_Identifier
(Arg1
, Name_Message
);
20543 if Arg_Count
= 2 then
20544 Check_Optional_Identifier
(Arg2
, Name_Version
);
20548 -- Get immediately preceding declaration
20551 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
20555 -- Cases where we do not follow anything other than another pragma
20559 -- First case: library level compilation unit declaration with
20560 -- the pragma immediately following the declaration.
20562 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
20564 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
20567 -- Case 2: library unit placement for package
20571 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
20573 if Is_Package_Or_Generic_Package
(Ent
) then
20574 Set_Obsolescent
(Ent
);
20580 -- Cases where we must follow a declaration, including an
20581 -- abstract subprogram declaration, which is not in the
20582 -- other node subtypes.
20585 if Nkind
(Decl
) not in N_Declaration
20586 and then Nkind
(Decl
) not in N_Later_Decl_Item
20587 and then Nkind
(Decl
) not in N_Generic_Declaration
20588 and then Nkind
(Decl
) not in N_Renaming_Declaration
20589 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
20592 ("pragma% misplaced, "
20593 & "must immediately follow a declaration");
20596 Set_Obsolescent
(Defining_Entity
(Decl
));
20606 -- pragma Optimize (Time | Space | Off);
20608 -- The actual check for optimize is done in Gigi. Note that this
20609 -- pragma does not actually change the optimization setting, it
20610 -- simply checks that it is consistent with the pragma.
20612 when Pragma_Optimize
=>
20613 Check_No_Identifiers
;
20614 Check_Arg_Count
(1);
20615 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
20617 ------------------------
20618 -- Optimize_Alignment --
20619 ------------------------
20621 -- pragma Optimize_Alignment (Time | Space | Off);
20623 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
20625 Check_No_Identifiers
;
20626 Check_Arg_Count
(1);
20627 Check_Valid_Configuration_Pragma
;
20630 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
20633 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
20634 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
20635 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
20638 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
20642 -- Set indication that mode is set locally. If we are in fact in a
20643 -- configuration pragma file, this setting is harmless since the
20644 -- switch will get reset anyway at the start of each unit.
20646 Optimize_Alignment_Local
:= True;
20647 end Optimize_Alignment
;
20653 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20655 when Pragma_Ordered
=> Ordered
: declare
20656 Assoc
: constant Node_Id
:= Arg1
;
20662 Check_No_Identifiers
;
20663 Check_Arg_Count
(1);
20664 Check_Arg_Is_Local_Name
(Arg1
);
20666 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20667 Find_Type
(Type_Id
);
20668 Typ
:= Entity
(Type_Id
);
20670 if Typ
= Any_Type
then
20673 Typ
:= Underlying_Type
(Typ
);
20676 if not Is_Enumeration_Type
(Typ
) then
20677 Error_Pragma
("pragma% must specify enumeration type");
20680 Check_First_Subtype
(Arg1
);
20681 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
20684 -------------------
20685 -- Overflow_Mode --
20686 -------------------
20688 -- pragma Overflow_Mode
20689 -- ([General => ] MODE [, [Assertions => ] MODE]);
20691 -- MODE := STRICT | MINIMIZED | ELIMINATED
20693 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20694 -- since System.Bignums makes this assumption. This is true of nearly
20695 -- all (all?) targets.
20697 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
20698 function Get_Overflow_Mode
20700 Arg
: Node_Id
) return Overflow_Mode_Type
;
20701 -- Function to process one pragma argument, Arg. If an identifier
20702 -- is present, it must be Name. Mode type is returned if a valid
20703 -- argument exists, otherwise an error is signalled.
20705 -----------------------
20706 -- Get_Overflow_Mode --
20707 -----------------------
20709 function Get_Overflow_Mode
20711 Arg
: Node_Id
) return Overflow_Mode_Type
20713 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
20716 Check_Optional_Identifier
(Arg
, Name
);
20717 Check_Arg_Is_Identifier
(Argx
);
20719 if Chars
(Argx
) = Name_Strict
then
20722 elsif Chars
(Argx
) = Name_Minimized
then
20725 elsif Chars
(Argx
) = Name_Eliminated
then
20726 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
20728 ("Eliminated requires Long_Long_Integer'Size = 64",
20735 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
20737 end Get_Overflow_Mode
;
20739 -- Start of processing for Overflow_Mode
20743 Check_At_Least_N_Arguments
(1);
20744 Check_At_Most_N_Arguments
(2);
20746 -- Process first argument
20748 Scope_Suppress
.Overflow_Mode_General
:=
20749 Get_Overflow_Mode
(Name_General
, Arg1
);
20751 -- Case of only one argument
20753 if Arg_Count
= 1 then
20754 Scope_Suppress
.Overflow_Mode_Assertions
:=
20755 Scope_Suppress
.Overflow_Mode_General
;
20757 -- Case of two arguments present
20760 Scope_Suppress
.Overflow_Mode_Assertions
:=
20761 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
20765 --------------------------
20766 -- Overriding Renamings --
20767 --------------------------
20769 -- pragma Overriding_Renamings;
20771 when Pragma_Overriding_Renamings
=>
20773 Check_Arg_Count
(0);
20774 Check_Valid_Configuration_Pragma
;
20775 Overriding_Renamings
:= True;
20781 -- pragma Pack (first_subtype_LOCAL_NAME);
20783 when Pragma_Pack
=> Pack
: declare
20784 Assoc
: constant Node_Id
:= Arg1
;
20786 Ignore
: Boolean := False;
20791 Check_No_Identifiers
;
20792 Check_Arg_Count
(1);
20793 Check_Arg_Is_Local_Name
(Arg1
);
20794 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20796 if not Is_Entity_Name
(Type_Id
)
20797 or else not Is_Type
(Entity
(Type_Id
))
20800 ("argument for pragma% must be type or subtype", Arg1
);
20803 Find_Type
(Type_Id
);
20804 Typ
:= Entity
(Type_Id
);
20807 or else Rep_Item_Too_Early
(Typ
, N
)
20811 Typ
:= Underlying_Type
(Typ
);
20814 -- A pragma that applies to a Ghost entity becomes Ghost for the
20815 -- purposes of legality checks and removal of ignored Ghost code.
20817 Mark_Ghost_Pragma
(N
, Typ
);
20819 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
20820 Error_Pragma
("pragma% must specify array or record type");
20823 Check_First_Subtype
(Arg1
);
20824 Check_Duplicate_Pragma
(Typ
);
20828 if Is_Array_Type
(Typ
) then
20829 Ctyp
:= Component_Type
(Typ
);
20831 -- Ignore pack that does nothing
20833 if Known_Static_Esize
(Ctyp
)
20834 and then Known_Static_RM_Size
(Ctyp
)
20835 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
20836 and then Addressable
(Esize
(Ctyp
))
20841 -- Process OK pragma Pack. Note that if there is a separate
20842 -- component clause present, the Pack will be cancelled. This
20843 -- processing is in Freeze.
20845 if not Rep_Item_Too_Late
(Typ
, N
) then
20847 -- In CodePeer mode, we do not need complex front-end
20848 -- expansions related to pragma Pack, so disable handling
20851 if CodePeer_Mode
then
20854 -- Normal case where we do the pack action
20858 Set_Is_Packed
(Base_Type
(Typ
));
20859 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20862 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20866 -- For record types, the pack is always effective
20868 else pragma Assert
(Is_Record_Type
(Typ
));
20869 if not Rep_Item_Too_Late
(Typ
, N
) then
20870 Set_Is_Packed
(Base_Type
(Typ
));
20871 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20872 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20883 -- There is nothing to do here, since we did all the processing for
20884 -- this pragma in Par.Prag (so that it works properly even in syntax
20887 when Pragma_Page
=>
20894 -- pragma Part_Of (ABSTRACT_STATE);
20896 -- ABSTRACT_STATE ::= NAME
20898 when Pragma_Part_Of
=> Part_Of
: declare
20899 procedure Propagate_Part_Of
20900 (Pack_Id
: Entity_Id
;
20901 State_Id
: Entity_Id
;
20902 Instance
: Node_Id
);
20903 -- Propagate the Part_Of indicator to all abstract states and
20904 -- objects declared in the visible state space of a package
20905 -- denoted by Pack_Id. State_Id is the encapsulating state.
20906 -- Instance is the package instantiation node.
20908 -----------------------
20909 -- Propagate_Part_Of --
20910 -----------------------
20912 procedure Propagate_Part_Of
20913 (Pack_Id
: Entity_Id
;
20914 State_Id
: Entity_Id
;
20915 Instance
: Node_Id
)
20917 Has_Item
: Boolean := False;
20918 -- Flag set when the visible state space contains at least one
20919 -- abstract state or variable.
20921 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
20922 -- Propagate the Part_Of indicator to all abstract states and
20923 -- objects declared in the visible state space of a package
20924 -- denoted by Pack_Id.
20926 -----------------------
20927 -- Propagate_Part_Of --
20928 -----------------------
20930 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
20931 Constits
: Elist_Id
;
20932 Item_Id
: Entity_Id
;
20935 -- Traverse the entity chain of the package and set relevant
20936 -- attributes of abstract states and objects declared in the
20937 -- visible state space of the package.
20939 Item_Id
:= First_Entity
(Pack_Id
);
20940 while Present
(Item_Id
)
20941 and then not In_Private_Part
(Item_Id
)
20943 -- Do not consider internally generated items
20945 if not Comes_From_Source
(Item_Id
) then
20948 -- Do not consider generic formals or their corresponding
20949 -- actuals because they are not part of a visible state.
20950 -- Note that both entities are marked as hidden.
20952 elsif Is_Hidden
(Item_Id
) then
20955 -- The Part_Of indicator turns an abstract state or an
20956 -- object into a constituent of the encapsulating state.
20957 -- Note that constants are considered here even though
20958 -- they may not depend on variable input. This check is
20959 -- left to the SPARK prover.
20961 elsif Ekind
(Item_Id
) in
20962 E_Abstract_State | E_Constant | E_Variable
20965 Constits
:= Part_Of_Constituents
(State_Id
);
20967 if No
(Constits
) then
20968 Constits
:= New_Elmt_List
;
20969 Set_Part_Of_Constituents
(State_Id
, Constits
);
20972 Append_Elmt
(Item_Id
, Constits
);
20973 Set_Encapsulating_State
(Item_Id
, State_Id
);
20975 -- Recursively handle nested packages and instantiations
20977 elsif Ekind
(Item_Id
) = E_Package
then
20978 Propagate_Part_Of
(Item_Id
);
20981 Next_Entity
(Item_Id
);
20983 end Propagate_Part_Of
;
20985 -- Start of processing for Propagate_Part_Of
20988 Propagate_Part_Of
(Pack_Id
);
20990 -- Detect a package instantiation that is subject to a Part_Of
20991 -- indicator, but has no visible state.
20993 if not Has_Item
then
20995 ("package instantiation & has Part_Of indicator but "
20996 & "lacks visible state", Instance
, Pack_Id
);
20998 end Propagate_Part_Of
;
21002 Constits
: Elist_Id
;
21004 Encap_Id
: Entity_Id
;
21005 Item_Id
: Entity_Id
;
21009 -- Start of processing for Part_Of
21013 Check_No_Identifiers
;
21014 Check_Arg_Count
(1);
21016 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
21018 -- Object declaration
21020 if Nkind
(Stmt
) = N_Object_Declaration
then
21023 -- Package instantiation
21025 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
21028 -- Single concurrent type declaration
21030 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
21033 -- Otherwise the pragma is associated with an illegal construct
21040 -- Extract the entity of the related object declaration or package
21041 -- instantiation. In the case of the instantiation, use the entity
21042 -- of the instance spec.
21044 if Nkind
(Stmt
) = N_Package_Instantiation
then
21045 Stmt
:= Instance_Spec
(Stmt
);
21048 Item_Id
:= Defining_Entity
(Stmt
);
21050 -- A pragma that applies to a Ghost entity becomes Ghost for the
21051 -- purposes of legality checks and removal of ignored Ghost code.
21053 Mark_Ghost_Pragma
(N
, Item_Id
);
21055 -- Chain the pragma on the contract for further processing by
21056 -- Analyze_Part_Of_In_Decl_Part or for completeness.
21058 Add_Contract_Item
(N
, Item_Id
);
21060 -- A variable may act as constituent of a single concurrent type
21061 -- which in turn could be declared after the variable. Due to this
21062 -- discrepancy, the full analysis of indicator Part_Of is delayed
21063 -- until the end of the enclosing declarative region (see routine
21064 -- Analyze_Part_Of_In_Decl_Part).
21066 if Ekind
(Item_Id
) = E_Variable
then
21069 -- Otherwise indicator Part_Of applies to a constant or a package
21073 Encap
:= Get_Pragma_Arg
(Arg1
);
21075 -- Detect any discrepancies between the placement of the
21076 -- constant or package instantiation with respect to state
21077 -- space and the encapsulating state.
21081 Item_Id
=> Item_Id
,
21083 Encap_Id
=> Encap_Id
,
21087 pragma Assert
(Present
(Encap_Id
));
21089 if Ekind
(Item_Id
) = E_Constant
then
21090 Constits
:= Part_Of_Constituents
(Encap_Id
);
21092 if No
(Constits
) then
21093 Constits
:= New_Elmt_List
;
21094 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
21097 Append_Elmt
(Item_Id
, Constits
);
21098 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
21100 -- Propagate the Part_Of indicator to the visible state
21101 -- space of the package instantiation.
21105 (Pack_Id
=> Item_Id
,
21106 State_Id
=> Encap_Id
,
21113 ----------------------------------
21114 -- Partition_Elaboration_Policy --
21115 ----------------------------------
21117 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
21119 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
21120 subtype PEP_Range
is Name_Id
21121 range First_Partition_Elaboration_Policy_Name
21122 .. Last_Partition_Elaboration_Policy_Name
;
21123 PEP_Val
: PEP_Range
;
21128 Check_Arg_Count
(1);
21129 Check_No_Identifiers
;
21130 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
21131 Check_Valid_Configuration_Pragma
;
21132 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
21135 when Name_Concurrent
=> PEP
:= 'C';
21136 when Name_Sequential
=> PEP
:= 'S';
21139 if Partition_Elaboration_Policy
/= ' '
21140 and then Partition_Elaboration_Policy
/= PEP
21142 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
21144 ("partition elaboration policy incompatible with policy#");
21146 -- Set new policy, but always preserve System_Location since we
21147 -- like the error message with the run time name.
21150 Partition_Elaboration_Policy
:= PEP
;
21152 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
21153 Partition_Elaboration_Policy_Sloc
:= Loc
;
21162 -- pragma Passive [(PASSIVE_FORM)];
21164 -- PASSIVE_FORM ::= Semaphore | No
21166 when Pragma_Passive
=>
21169 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
21170 Error_Pragma
("pragma% must be within task definition");
21173 if Arg_Count
/= 0 then
21174 Check_Arg_Count
(1);
21175 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
21178 ----------------------------------
21179 -- Preelaborable_Initialization --
21180 ----------------------------------
21182 -- pragma Preelaborable_Initialization (DIRECT_NAME);
21184 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
21189 Check_Arg_Count
(1);
21190 Check_No_Identifiers
;
21191 Check_Arg_Is_Identifier
(Arg1
);
21192 Check_Arg_Is_Local_Name
(Arg1
);
21193 Check_First_Subtype
(Arg1
);
21194 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21196 -- A pragma that applies to a Ghost entity becomes Ghost for the
21197 -- purposes of legality checks and removal of ignored Ghost code.
21199 Mark_Ghost_Pragma
(N
, Ent
);
21201 -- The pragma may come from an aspect on a private declaration,
21202 -- even if the freeze point at which this is analyzed in the
21203 -- private part after the full view.
21205 if Has_Private_Declaration
(Ent
)
21206 and then From_Aspect_Specification
(N
)
21210 -- Check appropriate type argument
21212 elsif Is_Private_Type
(Ent
)
21213 or else Is_Protected_Type
(Ent
)
21214 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
21216 -- AI05-0028: The pragma applies to all composite types. Note
21217 -- that we apply this binding interpretation to earlier versions
21218 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
21219 -- choice since there are other compilers that do the same.
21221 or else Is_Composite_Type
(Ent
)
21227 ("pragma % can only be applied to private, formal derived, "
21228 & "protected, or composite type", Arg1
);
21231 -- Give an error if the pragma is applied to a protected type that
21232 -- does not qualify (due to having entries, or due to components
21233 -- that do not qualify).
21235 if Is_Protected_Type
(Ent
)
21236 and then not Has_Preelaborable_Initialization
(Ent
)
21239 ("protected type & does not have preelaborable "
21240 & "initialization", Ent
);
21242 -- Otherwise mark the type as definitely having preelaborable
21246 Set_Known_To_Have_Preelab_Init
(Ent
);
21249 if Has_Pragma_Preelab_Init
(Ent
)
21250 and then Warn_On_Redundant_Constructs
21252 Error_Pragma
("?r?duplicate pragma%!");
21254 Set_Has_Pragma_Preelab_Init
(Ent
);
21258 --------------------
21259 -- Persistent_BSS --
21260 --------------------
21262 -- pragma Persistent_BSS [(object_NAME)];
21264 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21271 Check_At_Most_N_Arguments
(1);
21273 -- Case of application to specific object (one argument)
21275 if Arg_Count
= 1 then
21276 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21278 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21280 Ekind
(Entity
(Get_Pragma_Arg
(Arg1
))) not in
21281 E_Variable | E_Constant
21283 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21286 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21288 -- A pragma that applies to a Ghost entity becomes Ghost for
21289 -- the purposes of legality checks and removal of ignored Ghost
21292 Mark_Ghost_Pragma
(N
, Ent
);
21294 -- Check for duplication before inserting in list of
21295 -- representation items.
21297 Check_Duplicate_Pragma
(Ent
);
21299 if Rep_Item_Too_Late
(Ent
, N
) then
21303 Decl
:= Parent
(Ent
);
21305 if Present
(Expression
(Decl
)) then
21306 -- Variables in Persistent_BSS cannot be initialized, so
21307 -- turn off any initialization that might be caused by
21308 -- pragmas Initialize_Scalars or Normalize_Scalars.
21310 if Kill_Range_Check
(Expression
(Decl
)) then
21313 Name_Suppress_Initialization
,
21314 Pragma_Argument_Associations
=> New_List
(
21315 Make_Pragma_Argument_Association
(Loc
,
21316 Expression
=> New_Occurrence_Of
(Ent
, Loc
))));
21317 Insert_Before
(N
, Prag
);
21322 ("object for pragma% cannot have initialization", Arg1
);
21326 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
21328 ("object type for pragma% is not potentially persistent",
21333 Make_Linker_Section_Pragma
21334 (Ent
, Loc
, ".persistent.bss");
21335 Insert_After
(N
, Prag
);
21338 -- Case of use as configuration pragma with no arguments
21341 Check_Valid_Configuration_Pragma
;
21342 Persistent_BSS_Mode
:= True;
21344 end Persistent_BSS
;
21346 --------------------
21347 -- Rename_Pragma --
21348 --------------------
21350 -- pragma Rename_Pragma (
21351 -- [New_Name =>] IDENTIFIER,
21352 -- [Renamed =>] pragma_IDENTIFIER);
21354 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
21355 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21356 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21360 Check_Valid_Configuration_Pragma
;
21361 Check_Arg_Count
(2);
21362 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
21363 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
21365 if Nkind
(New_Name
) /= N_Identifier
then
21366 Error_Pragma_Arg
("identifier expected", Arg1
);
21369 if Nkind
(Old_Name
) /= N_Identifier
then
21370 Error_Pragma_Arg
("identifier expected", Arg2
);
21373 -- The New_Name arg should not be an existing pragma (but we allow
21374 -- it; it's just a warning). The Old_Name arg must be an existing
21377 if Is_Pragma_Name
(Chars
(New_Name
)) then
21378 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
21381 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
21382 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
21385 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
21388 -----------------------------------
21389 -- Post/Post_Class/Postcondition --
21390 -----------------------------------
21392 -- pragma Post (Boolean_EXPRESSION);
21393 -- pragma Post_Class (Boolean_EXPRESSION);
21394 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21395 -- [,[Message =>] String_EXPRESSION]);
21397 -- Characteristics:
21399 -- * Analysis - The annotation undergoes initial checks to verify
21400 -- the legal placement and context. Secondary checks preanalyze the
21403 -- Analyze_Pre_Post_Condition_In_Decl_Part
21405 -- * Expansion - The annotation is expanded during the expansion of
21406 -- the related subprogram [body] contract as performed in:
21408 -- Expand_Subprogram_Contract
21410 -- * Template - The annotation utilizes the generic template of the
21411 -- related subprogram [body] when it is:
21413 -- aspect on subprogram declaration
21414 -- aspect on stand-alone subprogram body
21415 -- pragma on stand-alone subprogram body
21417 -- The annotation must prepare its own template when it is:
21419 -- pragma on subprogram declaration
21421 -- * Globals - Capture of global references must occur after full
21424 -- * Instance - The annotation is instantiated automatically when
21425 -- the related generic subprogram [body] is instantiated except for
21426 -- the "pragma on subprogram declaration" case. In that scenario
21427 -- the annotation must instantiate itself.
21430 | Pragma_Post_Class
21431 | Pragma_Postcondition
21433 Analyze_Pre_Post_Condition
;
21435 --------------------------------
21436 -- Pre/Pre_Class/Precondition --
21437 --------------------------------
21439 -- pragma Pre (Boolean_EXPRESSION);
21440 -- pragma Pre_Class (Boolean_EXPRESSION);
21441 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21442 -- [,[Message =>] String_EXPRESSION]);
21444 -- Characteristics:
21446 -- * Analysis - The annotation undergoes initial checks to verify
21447 -- the legal placement and context. Secondary checks preanalyze the
21450 -- Analyze_Pre_Post_Condition_In_Decl_Part
21452 -- * Expansion - The annotation is expanded during the expansion of
21453 -- the related subprogram [body] contract as performed in:
21455 -- Expand_Subprogram_Contract
21457 -- * Template - The annotation utilizes the generic template of the
21458 -- related subprogram [body] when it is:
21460 -- aspect on subprogram declaration
21461 -- aspect on stand-alone subprogram body
21462 -- pragma on stand-alone subprogram body
21464 -- The annotation must prepare its own template when it is:
21466 -- pragma on subprogram declaration
21468 -- * Globals - Capture of global references must occur after full
21471 -- * Instance - The annotation is instantiated automatically when
21472 -- the related generic subprogram [body] is instantiated except for
21473 -- the "pragma on subprogram declaration" case. In that scenario
21474 -- the annotation must instantiate itself.
21478 | Pragma_Precondition
21480 Analyze_Pre_Post_Condition
;
21486 -- pragma Predicate
21487 -- ([Entity =>] type_LOCAL_NAME,
21488 -- [Check =>] boolean_EXPRESSION);
21490 when Pragma_Predicate
=> Predicate
: declare
21497 Check_Arg_Count
(2);
21498 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21499 Check_Optional_Identifier
(Arg2
, Name_Check
);
21501 Check_Arg_Is_Local_Name
(Arg1
);
21503 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21504 Find_Type
(Type_Id
);
21505 Typ
:= Entity
(Type_Id
);
21507 if Typ
= Any_Type
then
21511 -- A pragma that applies to a Ghost entity becomes Ghost for the
21512 -- purposes of legality checks and removal of ignored Ghost code.
21514 Mark_Ghost_Pragma
(N
, Typ
);
21516 -- The remaining processing is simply to link the pragma on to
21517 -- the rep item chain, for processing when the type is frozen.
21518 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21519 -- mark the type as having predicates.
21521 -- If the current policy for predicate checking is Ignore mark the
21522 -- subtype accordingly. In the case of predicates we consider them
21523 -- enabled unless Ignore is specified (either directly or with a
21524 -- general Assertion_Policy pragma) to preserve existing warnings.
21526 Set_Has_Predicates
(Typ
);
21528 -- Indicate that the pragma must be processed at the point the
21529 -- type is frozen, as is done for the corresponding aspect.
21531 Set_Has_Delayed_Aspects
(Typ
);
21532 Set_Has_Delayed_Freeze
(Typ
);
21534 Set_Predicates_Ignored
(Typ
,
21535 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
21536 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21539 -----------------------
21540 -- Predicate_Failure --
21541 -----------------------
21543 -- pragma Predicate_Failure
21544 -- ([Entity =>] type_LOCAL_NAME,
21545 -- [Message =>] string_EXPRESSION);
21547 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
21554 Check_Arg_Count
(2);
21555 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21556 Check_Optional_Identifier
(Arg2
, Name_Message
);
21558 Check_Arg_Is_Local_Name
(Arg1
);
21560 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21561 Find_Type
(Type_Id
);
21562 Typ
:= Entity
(Type_Id
);
21564 if Typ
= Any_Type
then
21568 -- A pragma that applies to a Ghost entity becomes Ghost for the
21569 -- purposes of legality checks and removal of ignored Ghost code.
21571 Mark_Ghost_Pragma
(N
, Typ
);
21573 -- The remaining processing is simply to link the pragma on to
21574 -- the rep item chain, for processing when the type is frozen.
21575 -- This is accomplished by a call to Rep_Item_Too_Late.
21577 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21578 end Predicate_Failure
;
21584 -- pragma Preelaborate [(library_unit_NAME)];
21586 -- Set the flag Is_Preelaborated of program unit name entity
21588 when Pragma_Preelaborate
=> Preelaborate
: declare
21589 Pa
: constant Node_Id
:= Parent
(N
);
21590 Pk
: constant Node_Kind
:= Nkind
(Pa
);
21594 Check_Ada_83_Warning
;
21595 Check_Valid_Library_Unit_Pragma
;
21597 -- If N was rewritten as a null statement there is nothing more
21600 if Nkind
(N
) = N_Null_Statement
then
21604 Ent
:= Find_Lib_Unit_Name
;
21606 -- A pragma that applies to a Ghost entity becomes Ghost for the
21607 -- purposes of legality checks and removal of ignored Ghost code.
21609 Mark_Ghost_Pragma
(N
, Ent
);
21610 Check_Duplicate_Pragma
(Ent
);
21612 -- This filters out pragmas inside generic parents that show up
21613 -- inside instantiations. Pragmas that come from aspects in the
21614 -- unit are not ignored.
21616 if Present
(Ent
) then
21617 if Pk
= N_Package_Specification
21618 and then Present
(Generic_Parent
(Pa
))
21619 and then not From_Aspect_Specification
(N
)
21624 if not Debug_Flag_U
then
21625 Set_Is_Preelaborated
(Ent
);
21627 if Legacy_Elaboration_Checks
then
21628 Set_Suppress_Elaboration_Warnings
(Ent
);
21635 -------------------------------
21636 -- Prefix_Exception_Messages --
21637 -------------------------------
21639 -- pragma Prefix_Exception_Messages;
21641 when Pragma_Prefix_Exception_Messages
=>
21643 Check_Valid_Configuration_Pragma
;
21644 Check_Arg_Count
(0);
21645 Prefix_Exception_Messages
:= True;
21651 -- pragma Priority (EXPRESSION);
21653 when Pragma_Priority
=> Priority
: declare
21654 P
: constant Node_Id
:= Parent
(N
);
21659 Check_No_Identifiers
;
21660 Check_Arg_Count
(1);
21664 if Nkind
(P
) = N_Subprogram_Body
then
21665 Check_In_Main_Program
;
21667 Ent
:= Defining_Unit_Name
(Specification
(P
));
21669 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
21670 Ent
:= Defining_Identifier
(Ent
);
21673 Arg
:= Get_Pragma_Arg
(Arg1
);
21674 Analyze_And_Resolve
(Arg
, Standard_Integer
);
21678 if not Is_OK_Static_Expression
(Arg
) then
21679 Flag_Non_Static_Expr
21680 ("main subprogram priority is not static!", Arg
);
21683 -- If constraint error, then we already signalled an error
21685 elsif Raises_Constraint_Error
(Arg
) then
21688 -- Otherwise check in range except if Relaxed_RM_Semantics
21689 -- where we ignore the value if out of range.
21692 if not Relaxed_RM_Semantics
21693 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
21696 ("main subprogram priority is out of range", Arg1
);
21699 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
21703 -- Load an arbitrary entity from System.Tasking.Stages or
21704 -- System.Tasking.Restricted.Stages (depending on the
21705 -- supported profile) to make sure that one of these packages
21706 -- is implicitly with'ed, since we need to have the tasking
21707 -- run time active for the pragma Priority to have any effect.
21708 -- Previously we with'ed the package System.Tasking, but this
21709 -- package does not trigger the required initialization of the
21710 -- run-time library.
21712 if Restricted_Profile
then
21713 Discard_Node
(RTE
(RE_Activate_Restricted_Tasks
));
21715 Discard_Node
(RTE
(RE_Activate_Tasks
));
21718 -- Task or Protected, must be of type Integer
21720 elsif Nkind
(P
) in N_Protected_Definition | N_Task_Definition
then
21721 Arg
:= Get_Pragma_Arg
(Arg1
);
21722 Ent
:= Defining_Identifier
(Parent
(P
));
21724 -- The expression must be analyzed in the special manner
21725 -- described in "Handling of Default and Per-Object
21726 -- Expressions" in sem.ads.
21728 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
21730 if not Is_OK_Static_Expression
(Arg
) then
21731 Check_Restriction
(Static_Priorities
, Arg
);
21734 -- Anything else is incorrect
21740 -- Check duplicate pragma before we chain the pragma in the Rep
21741 -- Item chain of Ent.
21743 Check_Duplicate_Pragma
(Ent
);
21744 Record_Rep_Item
(Ent
, N
);
21747 -----------------------------------
21748 -- Priority_Specific_Dispatching --
21749 -----------------------------------
21751 -- pragma Priority_Specific_Dispatching (
21752 -- policy_IDENTIFIER,
21753 -- first_priority_EXPRESSION,
21754 -- last_priority_EXPRESSION);
21756 when Pragma_Priority_Specific_Dispatching
=>
21757 Priority_Specific_Dispatching
: declare
21758 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
21759 -- This is the entity System.Any_Priority;
21762 Lower_Bound
: Node_Id
;
21763 Upper_Bound
: Node_Id
;
21769 Check_Arg_Count
(3);
21770 Check_No_Identifiers
;
21771 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21772 Check_Valid_Configuration_Pragma
;
21773 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21774 DP
:= Fold_Upper
(Name_Buffer
(1));
21776 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
21777 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
21778 Lower_Val
:= Expr_Value
(Lower_Bound
);
21780 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
21781 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
21782 Upper_Val
:= Expr_Value
(Upper_Bound
);
21784 -- It is not allowed to use Task_Dispatching_Policy and
21785 -- Priority_Specific_Dispatching in the same partition.
21787 if Task_Dispatching_Policy
/= ' ' then
21788 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21790 ("pragma% incompatible with Task_Dispatching_Policy#");
21792 -- Check lower bound in range
21794 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21796 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21799 ("first_priority is out of range", Arg2
);
21801 -- Check upper bound in range
21803 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21805 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21808 ("last_priority is out of range", Arg3
);
21810 -- Check that the priority range is valid
21812 elsif Lower_Val
> Upper_Val
then
21814 ("last_priority_expression must be greater than or equal to "
21815 & "first_priority_expression");
21817 -- Store the new policy, but always preserve System_Location since
21818 -- we like the error message with the run-time name.
21821 -- Check overlapping in the priority ranges specified in other
21822 -- Priority_Specific_Dispatching pragmas within the same
21823 -- partition. We can only check those we know about.
21826 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
21828 if Specific_Dispatching
.Table
(J
).First_Priority
in
21829 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21830 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
21831 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21834 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
21836 ("priority range overlaps with "
21837 & "Priority_Specific_Dispatching#");
21841 -- The use of Priority_Specific_Dispatching is incompatible
21842 -- with Task_Dispatching_Policy.
21844 if Task_Dispatching_Policy
/= ' ' then
21845 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21847 ("Priority_Specific_Dispatching incompatible "
21848 & "with Task_Dispatching_Policy#");
21851 -- The use of Priority_Specific_Dispatching forces ceiling
21854 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
21855 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
21857 ("Priority_Specific_Dispatching incompatible "
21858 & "with Locking_Policy#");
21860 -- Set the Ceiling_Locking policy, but preserve System_Location
21861 -- since we like the error message with the run time name.
21864 Locking_Policy
:= 'C';
21866 if Locking_Policy_Sloc
/= System_Location
then
21867 Locking_Policy_Sloc
:= Loc
;
21871 -- Add entry in the table
21873 Specific_Dispatching
.Append
21874 ((Dispatching_Policy
=> DP
,
21875 First_Priority
=> UI_To_Int
(Lower_Val
),
21876 Last_Priority
=> UI_To_Int
(Upper_Val
),
21877 Pragma_Loc
=> Loc
));
21879 end Priority_Specific_Dispatching
;
21885 -- pragma Profile (profile_IDENTIFIER);
21887 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21889 when Pragma_Profile
=>
21891 Check_Arg_Count
(1);
21892 Check_Valid_Configuration_Pragma
;
21893 Check_No_Identifiers
;
21896 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21899 if Nkind
(Argx
) /= N_Identifier
then
21901 ("argument of pragma Profile must be an identifier", N
);
21903 elsif Chars
(Argx
) = Name_Ravenscar
then
21904 Set_Ravenscar_Profile
(Ravenscar
, N
);
21906 elsif Chars
(Argx
) = Name_Jorvik
then
21907 Set_Ravenscar_Profile
(Jorvik
, N
);
21909 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
21910 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
21912 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
21913 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
21915 elsif Chars
(Argx
) = Name_Restricted
then
21916 Set_Profile_Restrictions
21918 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21920 elsif Chars
(Argx
) = Name_Rational
then
21921 Set_Rational_Profile
;
21923 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21924 Set_Profile_Restrictions
21925 (No_Implementation_Extensions
,
21926 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21929 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21933 ----------------------
21934 -- Profile_Warnings --
21935 ----------------------
21937 -- pragma Profile_Warnings (profile_IDENTIFIER);
21939 -- profile_IDENTIFIER => Restricted | Ravenscar
21941 when Pragma_Profile_Warnings
=>
21943 Check_Arg_Count
(1);
21944 Check_Valid_Configuration_Pragma
;
21945 Check_No_Identifiers
;
21948 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21951 if Chars
(Argx
) = Name_Ravenscar
then
21952 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
21954 elsif Chars
(Argx
) = Name_Restricted
then
21955 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
21957 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21958 Set_Profile_Restrictions
21959 (No_Implementation_Extensions
, N
, Warn
=> True);
21962 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21966 --------------------------
21967 -- Propagate_Exceptions --
21968 --------------------------
21970 -- pragma Propagate_Exceptions;
21972 -- Note: this pragma is obsolete and has no effect
21974 when Pragma_Propagate_Exceptions
=>
21976 Check_Arg_Count
(0);
21978 if Warn_On_Obsolescent_Feature
then
21980 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21981 "and has no effect?j?", N
);
21984 -----------------------------
21985 -- Provide_Shift_Operators --
21986 -----------------------------
21988 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21990 when Pragma_Provide_Shift_Operators
=>
21991 Provide_Shift_Operators
: declare
21994 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21995 -- Insert declaration and pragma Instrinsic for named shift op
21997 ----------------------------
21998 -- Declare_Shift_Operator --
21999 ----------------------------
22001 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
22007 Make_Subprogram_Declaration
(Loc
,
22008 Make_Function_Specification
(Loc
,
22009 Defining_Unit_Name
=>
22010 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
22012 Result_Definition
=>
22013 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
22015 Parameter_Specifications
=> New_List
(
22016 Make_Parameter_Specification
(Loc
,
22017 Defining_Identifier
=>
22018 Make_Defining_Identifier
(Loc
, Name_Value
),
22020 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
22022 Make_Parameter_Specification
(Loc
,
22023 Defining_Identifier
=>
22024 Make_Defining_Identifier
(Loc
, Name_Amount
),
22026 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
22030 Chars
=> Name_Import
,
22031 Pragma_Argument_Associations
=> New_List
(
22032 Make_Pragma_Argument_Association
(Loc
,
22033 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
22034 Make_Pragma_Argument_Association
(Loc
,
22035 Expression
=> Make_Identifier
(Loc
, Nam
))));
22037 Insert_After
(N
, Import
);
22038 Insert_After
(N
, Func
);
22039 end Declare_Shift_Operator
;
22041 -- Start of processing for Provide_Shift_Operators
22045 Check_Arg_Count
(1);
22046 Check_Arg_Is_Local_Name
(Arg1
);
22048 Arg1
:= Get_Pragma_Arg
(Arg1
);
22050 -- We must have an entity name
22052 if not Is_Entity_Name
(Arg1
) then
22054 ("pragma % must apply to integer first subtype", Arg1
);
22057 -- If no Entity, means there was a prior error so ignore
22059 if Present
(Entity
(Arg1
)) then
22060 Ent
:= Entity
(Arg1
);
22062 -- Apply error checks
22064 if not Is_First_Subtype
(Ent
) then
22066 ("cannot apply pragma %",
22067 "\& is not a first subtype",
22070 elsif not Is_Integer_Type
(Ent
) then
22072 ("cannot apply pragma %",
22073 "\& is not an integer type",
22076 elsif Has_Shift_Operator
(Ent
) then
22078 ("cannot apply pragma %",
22079 "\& already has declared shift operators",
22082 elsif Is_Frozen
(Ent
) then
22084 ("pragma % appears too late",
22085 "\& is already frozen",
22089 -- Now declare the operators. We do this during analysis rather
22090 -- than expansion, since we want the operators available if we
22091 -- are operating in -gnatc mode.
22093 Declare_Shift_Operator
(Name_Rotate_Left
);
22094 Declare_Shift_Operator
(Name_Rotate_Right
);
22095 Declare_Shift_Operator
(Name_Shift_Left
);
22096 Declare_Shift_Operator
(Name_Shift_Right
);
22097 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
22099 end Provide_Shift_Operators
;
22105 -- pragma Psect_Object (
22106 -- [Internal =>] LOCAL_NAME,
22107 -- [, [External =>] EXTERNAL_SYMBOL]
22108 -- [, [Size =>] EXTERNAL_SYMBOL]);
22110 when Pragma_Common_Object
22111 | Pragma_Psect_Object
22113 Psect_Object
: declare
22114 Args
: Args_List
(1 .. 3);
22115 Names
: constant Name_List
(1 .. 3) := (
22120 Internal
: Node_Id
renames Args
(1);
22121 External
: Node_Id
renames Args
(2);
22122 Size
: Node_Id
renames Args
(3);
22124 Def_Id
: Entity_Id
;
22126 procedure Check_Arg
(Arg
: Node_Id
);
22127 -- Checks that argument is either a string literal or an
22128 -- identifier, and posts error message if not.
22134 procedure Check_Arg
(Arg
: Node_Id
) is
22136 if Nkind
(Original_Node
(Arg
)) not in
22137 N_String_Literal | N_Identifier
22140 ("inappropriate argument for pragma %", Arg
);
22144 -- Start of processing for Common_Object/Psect_Object
22148 Gather_Associations
(Names
, Args
);
22149 Process_Extended_Import_Export_Internal_Arg
(Internal
);
22151 Def_Id
:= Entity
(Internal
);
22153 if Ekind
(Def_Id
) not in E_Constant | E_Variable
then
22155 ("pragma% must designate an object", Internal
);
22158 Check_Arg
(Internal
);
22160 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
22162 ("cannot use pragma% for imported/exported object",
22166 if Is_Concurrent_Type
(Etype
(Internal
)) then
22168 ("cannot specify pragma % for task/protected object",
22172 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
22174 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
22176 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
22179 if Ekind
(Def_Id
) = E_Constant
then
22181 ("cannot specify pragma % for a constant", Internal
);
22184 if Is_Record_Type
(Etype
(Internal
)) then
22190 Ent
:= First_Entity
(Etype
(Internal
));
22191 while Present
(Ent
) loop
22192 Decl
:= Declaration_Node
(Ent
);
22194 if Ekind
(Ent
) = E_Component
22195 and then Nkind
(Decl
) = N_Component_Declaration
22196 and then Present
(Expression
(Decl
))
22197 and then Warn_On_Export_Import
22200 ("?x?object for pragma % has defaults", Internal
);
22210 if Present
(Size
) then
22214 if Present
(External
) then
22215 Check_Arg_Is_External_Name
(External
);
22218 -- If all error tests pass, link pragma on to the rep item chain
22220 Record_Rep_Item
(Def_Id
, N
);
22227 -- pragma Pure [(library_unit_NAME)];
22229 when Pragma_Pure
=> Pure
: declare
22233 Check_Ada_83_Warning
;
22235 -- If the pragma comes from a subprogram instantiation, nothing to
22236 -- check, this can happen at any level of nesting.
22238 if Is_Wrapper_Package
(Current_Scope
) then
22242 Check_Valid_Library_Unit_Pragma
;
22244 -- If N was rewritten as a null statement there is nothing more
22247 if Nkind
(N
) = N_Null_Statement
then
22251 Ent
:= Find_Lib_Unit_Name
;
22253 -- A pragma that applies to a Ghost entity becomes Ghost for the
22254 -- purposes of legality checks and removal of ignored Ghost code.
22256 Mark_Ghost_Pragma
(N
, Ent
);
22258 if not Debug_Flag_U
then
22260 Set_Has_Pragma_Pure
(Ent
);
22262 if Legacy_Elaboration_Checks
then
22263 Set_Suppress_Elaboration_Warnings
(Ent
);
22268 -------------------
22269 -- Pure_Function --
22270 -------------------
22272 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22274 when Pragma_Pure_Function
=> Pure_Function
: declare
22275 Def_Id
: Entity_Id
;
22278 Effective
: Boolean := False;
22279 Orig_Def
: Entity_Id
;
22280 Same_Decl
: Boolean := False;
22284 Check_Arg_Count
(1);
22285 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22286 Check_Arg_Is_Local_Name
(Arg1
);
22287 E_Id
:= Get_Pragma_Arg
(Arg1
);
22289 if Etype
(E_Id
) = Any_Type
then
22293 -- Loop through homonyms (overloadings) of referenced entity
22295 E
:= Entity
(E_Id
);
22297 -- A pragma that applies to a Ghost entity becomes Ghost for the
22298 -- purposes of legality checks and removal of ignored Ghost code.
22300 Mark_Ghost_Pragma
(N
, E
);
22302 if Present
(E
) then
22304 Def_Id
:= Get_Base_Subprogram
(E
);
22306 if Ekind
(Def_Id
) not in
22307 E_Function | E_Generic_Function | E_Operator
22310 ("pragma% requires a function name", Arg1
);
22313 -- When we have a generic function we must jump up a level
22314 -- to the declaration of the wrapper package itself.
22316 Orig_Def
:= Def_Id
;
22318 if Is_Generic_Instance
(Def_Id
) then
22319 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
22320 Orig_Def
:= Parent
(Orig_Def
);
22324 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
22326 Set_Is_Pure
(Def_Id
);
22328 if not Has_Pragma_Pure_Function
(Def_Id
) then
22329 Set_Has_Pragma_Pure_Function
(Def_Id
);
22334 exit when From_Aspect_Specification
(N
);
22336 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
22340 and then Warn_On_Redundant_Constructs
22343 ("pragma Pure_Function on& is redundant?r?",
22346 elsif not Same_Decl
then
22348 ("pragma% argument must be in same declarative part",
22354 --------------------
22355 -- Queuing_Policy --
22356 --------------------
22358 -- pragma Queuing_Policy (policy_IDENTIFIER);
22360 when Pragma_Queuing_Policy
=> declare
22364 Check_Ada_83_Warning
;
22365 Check_Arg_Count
(1);
22366 Check_No_Identifiers
;
22367 Check_Arg_Is_Queuing_Policy
(Arg1
);
22368 Check_Valid_Configuration_Pragma
;
22369 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22370 QP
:= Fold_Upper
(Name_Buffer
(1));
22372 if Queuing_Policy
/= ' '
22373 and then Queuing_Policy
/= QP
22375 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
22376 Error_Pragma
("queuing policy incompatible with policy#");
22378 -- Set new policy, but always preserve System_Location since we
22379 -- like the error message with the run time name.
22382 Queuing_Policy
:= QP
;
22384 if Queuing_Policy_Sloc
/= System_Location
then
22385 Queuing_Policy_Sloc
:= Loc
;
22394 -- pragma Rational, for compatibility with foreign compiler
22396 when Pragma_Rational
=>
22397 Set_Rational_Profile
;
22399 ---------------------
22400 -- Refined_Depends --
22401 ---------------------
22403 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22405 -- DEPENDENCY_RELATION ::=
22407 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22409 -- DEPENDENCY_CLAUSE ::=
22410 -- OUTPUT_LIST =>[+] INPUT_LIST
22411 -- | NULL_DEPENDENCY_CLAUSE
22413 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22415 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22417 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22419 -- OUTPUT ::= NAME | FUNCTION_RESULT
22422 -- where FUNCTION_RESULT is a function Result attribute_reference
22424 -- Characteristics:
22426 -- * Analysis - The annotation undergoes initial checks to verify
22427 -- the legal placement and context. Secondary checks fully analyze
22428 -- the dependency clauses/global list in:
22430 -- Analyze_Refined_Depends_In_Decl_Part
22432 -- * Expansion - None.
22434 -- * Template - The annotation utilizes the generic template of the
22435 -- related subprogram body.
22437 -- * Globals - Capture of global references must occur after full
22440 -- * Instance - The annotation is instantiated automatically when
22441 -- the related generic subprogram body is instantiated.
22443 when Pragma_Refined_Depends
=> Refined_Depends
: declare
22444 Body_Id
: Entity_Id
;
22446 Spec_Id
: Entity_Id
;
22449 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22453 -- Chain the pragma on the contract for further processing by
22454 -- Analyze_Refined_Depends_In_Decl_Part.
22456 Add_Contract_Item
(N
, Body_Id
);
22458 -- The legality checks of pragmas Refined_Depends and
22459 -- Refined_Global are affected by the SPARK mode in effect and
22460 -- the volatility of the context. In addition these two pragmas
22461 -- are subject to an inherent order:
22463 -- 1) Refined_Global
22464 -- 2) Refined_Depends
22466 -- Analyze all these pragmas in the order outlined above
22468 Analyze_If_Present
(Pragma_SPARK_Mode
);
22469 Analyze_If_Present
(Pragma_Volatile_Function
);
22470 Analyze_If_Present
(Pragma_Refined_Global
);
22471 Analyze_Refined_Depends_In_Decl_Part
(N
);
22473 end Refined_Depends
;
22475 --------------------
22476 -- Refined_Global --
22477 --------------------
22479 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22481 -- GLOBAL_SPECIFICATION ::=
22484 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22486 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22488 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22489 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22490 -- GLOBAL_ITEM ::= NAME
22492 -- Characteristics:
22494 -- * Analysis - The annotation undergoes initial checks to verify
22495 -- the legal placement and context. Secondary checks fully analyze
22496 -- the dependency clauses/global list in:
22498 -- Analyze_Refined_Global_In_Decl_Part
22500 -- * Expansion - None.
22502 -- * Template - The annotation utilizes the generic template of the
22503 -- related subprogram body.
22505 -- * Globals - Capture of global references must occur after full
22508 -- * Instance - The annotation is instantiated automatically when
22509 -- the related generic subprogram body is instantiated.
22511 when Pragma_Refined_Global
=> Refined_Global
: declare
22512 Body_Id
: Entity_Id
;
22514 Spec_Id
: Entity_Id
;
22517 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22521 -- Chain the pragma on the contract for further processing by
22522 -- Analyze_Refined_Global_In_Decl_Part.
22524 Add_Contract_Item
(N
, Body_Id
);
22526 -- The legality checks of pragmas Refined_Depends and
22527 -- Refined_Global are affected by the SPARK mode in effect and
22528 -- the volatility of the context. In addition these two pragmas
22529 -- are subject to an inherent order:
22531 -- 1) Refined_Global
22532 -- 2) Refined_Depends
22534 -- Analyze all these pragmas in the order outlined above
22536 Analyze_If_Present
(Pragma_SPARK_Mode
);
22537 Analyze_If_Present
(Pragma_Volatile_Function
);
22538 Analyze_Refined_Global_In_Decl_Part
(N
);
22539 Analyze_If_Present
(Pragma_Refined_Depends
);
22541 end Refined_Global
;
22547 -- pragma Refined_Post (boolean_EXPRESSION);
22549 -- Characteristics:
22551 -- * Analysis - The annotation is fully analyzed immediately upon
22552 -- elaboration as it cannot forward reference entities.
22554 -- * Expansion - The annotation is expanded during the expansion of
22555 -- the related subprogram body contract as performed in:
22557 -- Expand_Subprogram_Contract
22559 -- * Template - The annotation utilizes the generic template of the
22560 -- related subprogram body.
22562 -- * Globals - Capture of global references must occur after full
22565 -- * Instance - The annotation is instantiated automatically when
22566 -- the related generic subprogram body is instantiated.
22568 when Pragma_Refined_Post
=> Refined_Post
: declare
22569 Body_Id
: Entity_Id
;
22571 Spec_Id
: Entity_Id
;
22574 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22576 -- Fully analyze the pragma when it appears inside a subprogram
22577 -- body because it cannot benefit from forward references.
22581 -- Chain the pragma on the contract for completeness
22583 Add_Contract_Item
(N
, Body_Id
);
22585 -- The legality checks of pragma Refined_Post are affected by
22586 -- the SPARK mode in effect and the volatility of the context.
22587 -- Analyze all pragmas in a specific order.
22589 Analyze_If_Present
(Pragma_SPARK_Mode
);
22590 Analyze_If_Present
(Pragma_Volatile_Function
);
22591 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
22593 -- Currently it is not possible to inline pre/postconditions on
22594 -- a subprogram subject to pragma Inline_Always.
22596 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
22600 -------------------
22601 -- Refined_State --
22602 -------------------
22604 -- pragma Refined_State (REFINEMENT_LIST);
22606 -- REFINEMENT_LIST ::=
22607 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22609 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22611 -- CONSTITUENT_LIST ::=
22614 -- | (CONSTITUENT {, CONSTITUENT})
22616 -- CONSTITUENT ::= object_NAME | state_NAME
22618 -- Characteristics:
22620 -- * Analysis - The annotation undergoes initial checks to verify
22621 -- the legal placement and context. Secondary checks preanalyze the
22622 -- refinement clauses in:
22624 -- Analyze_Refined_State_In_Decl_Part
22626 -- * Expansion - None.
22628 -- * Template - The annotation utilizes the template of the related
22631 -- * Globals - Capture of global references must occur after full
22634 -- * Instance - The annotation is instantiated automatically when
22635 -- the related generic package body is instantiated.
22637 when Pragma_Refined_State
=> Refined_State
: declare
22638 Pack_Decl
: Node_Id
;
22639 Spec_Id
: Entity_Id
;
22643 Check_No_Identifiers
;
22644 Check_Arg_Count
(1);
22646 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
22648 if Nkind
(Pack_Decl
) /= N_Package_Body
then
22653 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
22655 -- A pragma that applies to a Ghost entity becomes Ghost for the
22656 -- purposes of legality checks and removal of ignored Ghost code.
22658 Mark_Ghost_Pragma
(N
, Spec_Id
);
22660 -- Chain the pragma on the contract for further processing by
22661 -- Analyze_Refined_State_In_Decl_Part.
22663 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
22665 -- The legality checks of pragma Refined_State are affected by the
22666 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22668 Analyze_If_Present
(Pragma_SPARK_Mode
);
22670 -- State refinement is allowed only when the corresponding package
22671 -- declaration has non-null pragma Abstract_State. Refinement not
22672 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22674 if SPARK_Mode
/= Off
22676 (No
(Abstract_States
(Spec_Id
))
22677 or else Has_Null_Abstract_State
(Spec_Id
))
22680 ("useless refinement, package & does not define abstract "
22681 & "states", N
, Spec_Id
);
22686 -----------------------
22687 -- Relative_Deadline --
22688 -----------------------
22690 -- pragma Relative_Deadline (time_span_EXPRESSION);
22692 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
22693 P
: constant Node_Id
:= Parent
(N
);
22698 Check_No_Identifiers
;
22699 Check_Arg_Count
(1);
22701 Arg
:= Get_Pragma_Arg
(Arg1
);
22703 -- The expression must be analyzed in the special manner described
22704 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22706 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
22710 if Nkind
(P
) = N_Subprogram_Body
then
22711 Check_In_Main_Program
;
22713 -- Only Task and subprogram cases allowed
22715 elsif Nkind
(P
) /= N_Task_Definition
then
22719 -- Check duplicate pragma before we set the corresponding flag
22721 if Has_Relative_Deadline_Pragma
(P
) then
22722 Error_Pragma
("duplicate pragma% not allowed");
22725 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22726 -- Relative_Deadline pragma node cannot be inserted in the Rep
22727 -- Item chain of Ent since it is rewritten by the expander as a
22728 -- procedure call statement that will break the chain.
22730 Set_Has_Relative_Deadline_Pragma
(P
);
22731 end Relative_Deadline
;
22733 ------------------------
22734 -- Remote_Access_Type --
22735 ------------------------
22737 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22739 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
22744 Check_Arg_Count
(1);
22745 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22746 Check_Arg_Is_Local_Name
(Arg1
);
22748 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
22750 -- A pragma that applies to a Ghost entity becomes Ghost for the
22751 -- purposes of legality checks and removal of ignored Ghost code.
22753 Mark_Ghost_Pragma
(N
, E
);
22755 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
22756 and then Ekind
(E
) = E_General_Access_Type
22757 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
22758 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
22760 and then Is_Valid_Remote_Object_Type
22761 (Root_Type
(Directly_Designated_Type
(E
)))
22763 Set_Is_Remote_Types
(E
);
22767 ("pragma% applies only to formal access-to-class-wide types",
22770 end Remote_Access_Type
;
22772 ---------------------------
22773 -- Remote_Call_Interface --
22774 ---------------------------
22776 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22778 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
22779 Cunit_Node
: Node_Id
;
22780 Cunit_Ent
: Entity_Id
;
22784 Check_Ada_83_Warning
;
22785 Check_Valid_Library_Unit_Pragma
;
22787 -- If N was rewritten as a null statement there is nothing more
22790 if Nkind
(N
) = N_Null_Statement
then
22794 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22795 K
:= Nkind
(Unit
(Cunit_Node
));
22796 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22798 -- A pragma that applies to a Ghost entity becomes Ghost for the
22799 -- purposes of legality checks and removal of ignored Ghost code.
22801 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22803 if K
= N_Package_Declaration
22804 or else K
= N_Generic_Package_Declaration
22805 or else K
= N_Subprogram_Declaration
22806 or else K
= N_Generic_Subprogram_Declaration
22807 or else (K
= N_Subprogram_Body
22808 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
22813 "pragma% must apply to package or subprogram declaration");
22816 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
22817 end Remote_Call_Interface
;
22823 -- pragma Remote_Types [(library_unit_NAME)];
22825 when Pragma_Remote_Types
=> Remote_Types
: declare
22826 Cunit_Node
: Node_Id
;
22827 Cunit_Ent
: Entity_Id
;
22830 Check_Ada_83_Warning
;
22831 Check_Valid_Library_Unit_Pragma
;
22833 -- If N was rewritten as a null statement there is nothing more
22836 if Nkind
(N
) = N_Null_Statement
then
22840 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22841 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22843 -- A pragma that applies to a Ghost entity becomes Ghost for the
22844 -- purposes of legality checks and removal of ignored Ghost code.
22846 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22848 if Nkind
(Unit
(Cunit_Node
)) not in
22849 N_Package_Declaration | N_Generic_Package_Declaration
22852 ("pragma% can only apply to a package declaration");
22855 Set_Is_Remote_Types
(Cunit_Ent
);
22862 -- pragma Ravenscar;
22864 when Pragma_Ravenscar
=>
22866 Check_Arg_Count
(0);
22867 Check_Valid_Configuration_Pragma
;
22868 Set_Ravenscar_Profile
(Ravenscar
, N
);
22870 if Warn_On_Obsolescent_Feature
then
22872 ("pragma Ravenscar is an obsolescent feature?j?", N
);
22874 ("|use pragma Profile (Ravenscar) instead?j?", N
);
22877 -------------------------
22878 -- Restricted_Run_Time --
22879 -------------------------
22881 -- pragma Restricted_Run_Time;
22883 when Pragma_Restricted_Run_Time
=>
22885 Check_Arg_Count
(0);
22886 Check_Valid_Configuration_Pragma
;
22887 Set_Profile_Restrictions
22888 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
22890 if Warn_On_Obsolescent_Feature
then
22892 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22895 ("|use pragma Profile (Restricted) instead?j?", N
);
22902 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22905 -- restriction_IDENTIFIER
22906 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22908 when Pragma_Restrictions
=>
22909 Process_Restrictions_Or_Restriction_Warnings
22910 (Warn
=> Treat_Restrictions_As_Warnings
);
22912 --------------------------
22913 -- Restriction_Warnings --
22914 --------------------------
22916 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22919 -- restriction_IDENTIFIER
22920 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22922 when Pragma_Restriction_Warnings
=>
22924 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
22930 -- pragma Reviewable;
22932 when Pragma_Reviewable
=>
22933 Check_Ada_83_Warning
;
22934 Check_Arg_Count
(0);
22936 -- Call dummy debugging function rv. This is done to assist front
22937 -- end debugging. By placing a Reviewable pragma in the source
22938 -- program, a breakpoint on rv catches this place in the source,
22939 -- allowing convenient stepping to the point of interest.
22943 --------------------------
22944 -- Secondary_Stack_Size --
22945 --------------------------
22947 -- pragma Secondary_Stack_Size (EXPRESSION);
22949 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
22950 P
: constant Node_Id
:= Parent
(N
);
22956 Check_No_Identifiers
;
22957 Check_Arg_Count
(1);
22959 if Nkind
(P
) = N_Task_Definition
then
22960 Arg
:= Get_Pragma_Arg
(Arg1
);
22961 Ent
:= Defining_Identifier
(Parent
(P
));
22963 -- The expression must be analyzed in the special manner
22964 -- described in "Handling of Default Expressions" in sem.ads.
22966 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22968 -- The pragma cannot appear if the No_Secondary_Stack
22969 -- restriction is in effect.
22971 Check_Restriction
(No_Secondary_Stack
, Arg
);
22973 -- Anything else is incorrect
22979 -- Check duplicate pragma before we chain the pragma in the Rep
22980 -- Item chain of Ent.
22982 Check_Duplicate_Pragma
(Ent
);
22983 Record_Rep_Item
(Ent
, N
);
22984 end Secondary_Stack_Size
;
22986 --------------------------
22987 -- Short_Circuit_And_Or --
22988 --------------------------
22990 -- pragma Short_Circuit_And_Or;
22992 when Pragma_Short_Circuit_And_Or
=>
22994 Check_Arg_Count
(0);
22995 Check_Valid_Configuration_Pragma
;
22996 Short_Circuit_And_Or
:= True;
22998 -------------------
22999 -- Share_Generic --
23000 -------------------
23002 -- pragma Share_Generic (GNAME {, GNAME});
23004 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
23006 when Pragma_Share_Generic
=>
23008 Process_Generic_List
;
23014 -- pragma Shared (LOCAL_NAME);
23016 when Pragma_Shared
=>
23018 Process_Atomic_Independent_Shared_Volatile
;
23020 --------------------
23021 -- Shared_Passive --
23022 --------------------
23024 -- pragma Shared_Passive [(library_unit_NAME)];
23026 -- Set the flag Is_Shared_Passive of program unit name entity
23028 when Pragma_Shared_Passive
=> Shared_Passive
: declare
23029 Cunit_Node
: Node_Id
;
23030 Cunit_Ent
: Entity_Id
;
23033 Check_Ada_83_Warning
;
23034 Check_Valid_Library_Unit_Pragma
;
23036 -- If N was rewritten as a null statement there is nothing more
23039 if Nkind
(N
) = N_Null_Statement
then
23043 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
23044 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
23046 -- A pragma that applies to a Ghost entity becomes Ghost for the
23047 -- purposes of legality checks and removal of ignored Ghost code.
23049 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
23051 if Nkind
(Unit
(Cunit_Node
)) not in
23052 N_Package_Declaration | N_Generic_Package_Declaration
23055 ("pragma% can only apply to a package declaration");
23058 Set_Is_Shared_Passive
(Cunit_Ent
);
23059 end Shared_Passive
;
23061 -----------------------
23062 -- Short_Descriptors --
23063 -----------------------
23065 -- pragma Short_Descriptors;
23067 -- Recognize and validate, but otherwise ignore
23069 when Pragma_Short_Descriptors
=>
23071 Check_Arg_Count
(0);
23072 Check_Valid_Configuration_Pragma
;
23074 ------------------------------
23075 -- Simple_Storage_Pool_Type --
23076 ------------------------------
23078 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
23080 when Pragma_Simple_Storage_Pool_Type
=>
23081 Simple_Storage_Pool_Type
: declare
23087 Check_Arg_Count
(1);
23088 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23090 Type_Id
:= Get_Pragma_Arg
(Arg1
);
23091 Find_Type
(Type_Id
);
23092 Typ
:= Entity
(Type_Id
);
23094 if Typ
= Any_Type
then
23098 -- A pragma that applies to a Ghost entity becomes Ghost for the
23099 -- purposes of legality checks and removal of ignored Ghost code.
23101 Mark_Ghost_Pragma
(N
, Typ
);
23103 -- We require the pragma to apply to a type declared in a package
23104 -- declaration, but not (immediately) within a package body.
23106 if Ekind
(Current_Scope
) /= E_Package
23107 or else In_Package_Body
(Current_Scope
)
23110 ("pragma% can only apply to type declared immediately "
23111 & "within a package declaration");
23114 -- A simple storage pool type must be an immutably limited record
23115 -- or private type. If the pragma is given for a private type,
23116 -- the full type is similarly restricted (which is checked later
23117 -- in Freeze_Entity).
23119 if Is_Record_Type
(Typ
)
23120 and then not Is_Limited_View
(Typ
)
23123 ("pragma% can only apply to explicitly limited record type");
23125 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
23127 ("pragma% can only apply to a private type that is limited");
23129 elsif not Is_Record_Type
(Typ
)
23130 and then not Is_Private_Type
(Typ
)
23133 ("pragma% can only apply to limited record or private type");
23136 Record_Rep_Item
(Typ
, N
);
23137 end Simple_Storage_Pool_Type
;
23139 ----------------------
23140 -- Source_File_Name --
23141 ----------------------
23143 -- There are five forms for this pragma:
23145 -- pragma Source_File_Name (
23146 -- [UNIT_NAME =>] unit_NAME,
23147 -- BODY_FILE_NAME => STRING_LITERAL
23148 -- [, [INDEX =>] INTEGER_LITERAL]);
23150 -- pragma Source_File_Name (
23151 -- [UNIT_NAME =>] unit_NAME,
23152 -- SPEC_FILE_NAME => STRING_LITERAL
23153 -- [, [INDEX =>] INTEGER_LITERAL]);
23155 -- pragma Source_File_Name (
23156 -- BODY_FILE_NAME => STRING_LITERAL
23157 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23158 -- [, CASING => CASING_SPEC]);
23160 -- pragma Source_File_Name (
23161 -- SPEC_FILE_NAME => STRING_LITERAL
23162 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23163 -- [, CASING => CASING_SPEC]);
23165 -- pragma Source_File_Name (
23166 -- SUBUNIT_FILE_NAME => STRING_LITERAL
23167 -- [, DOT_REPLACEMENT => STRING_LITERAL]
23168 -- [, CASING => CASING_SPEC]);
23170 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
23172 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
23173 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
23174 -- only be used when no project file is used, while SFNP can only be
23175 -- used when a project file is used.
23177 -- No processing here. Processing was completed during parsing, since
23178 -- we need to have file names set as early as possible. Units are
23179 -- loaded well before semantic processing starts.
23181 -- The only processing we defer to this point is the check for
23182 -- correct placement.
23184 when Pragma_Source_File_Name
=>
23186 Check_Valid_Configuration_Pragma
;
23188 ------------------------------
23189 -- Source_File_Name_Project --
23190 ------------------------------
23192 -- See Source_File_Name for syntax
23194 -- No processing here. Processing was completed during parsing, since
23195 -- we need to have file names set as early as possible. Units are
23196 -- loaded well before semantic processing starts.
23198 -- The only processing we defer to this point is the check for
23199 -- correct placement.
23201 when Pragma_Source_File_Name_Project
=>
23203 Check_Valid_Configuration_Pragma
;
23205 -- Check that a pragma Source_File_Name_Project is used only in a
23206 -- configuration pragmas file.
23208 -- Pragmas Source_File_Name_Project should only be generated by
23209 -- the Project Manager in configuration pragmas files.
23211 -- This is really an ugly test. It seems to depend on some
23212 -- accidental and undocumented property. At the very least it
23213 -- needs to be documented, but it would be better to have a
23214 -- clean way of testing if we are in a configuration file???
23216 if Present
(Parent
(N
)) then
23218 ("pragma% can only appear in a configuration pragmas file");
23221 ----------------------
23222 -- Source_Reference --
23223 ----------------------
23225 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
23227 -- Nothing to do, all processing completed in Par.Prag, since we need
23228 -- the information for possible parser messages that are output.
23230 when Pragma_Source_Reference
=>
23237 -- pragma SPARK_Mode [(On | Off)];
23239 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
23240 Mode_Id
: SPARK_Mode_Type
;
23242 procedure Check_Pragma_Conformance
23243 (Context_Pragma
: Node_Id
;
23244 Entity
: Entity_Id
;
23245 Entity_Pragma
: Node_Id
);
23246 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
23247 -- conformance of pragma N depending the following scenarios:
23249 -- If pragma Context_Pragma is not Empty, verify that pragma N is
23250 -- compatible with the pragma Context_Pragma that was inherited
23251 -- from the context:
23252 -- * If the mode of Context_Pragma is ON, then the new mode can
23254 -- * If the mode of Context_Pragma is OFF, then the only allowed
23255 -- new mode is also OFF. Emit error if this is not the case.
23257 -- If Entity is not Empty, verify that pragma N is compatible with
23258 -- pragma Entity_Pragma that belongs to Entity.
23259 -- * If Entity_Pragma is Empty, always issue an error as this
23260 -- corresponds to the case where a previous section of Entity
23261 -- has no SPARK_Mode set.
23262 -- * If the mode of Entity_Pragma is ON, then the new mode can
23264 -- * If the mode of Entity_Pragma is OFF, then the only allowed
23265 -- new mode is also OFF. Emit error if this is not the case.
23267 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
23268 -- Subsidiary to routines Process_xxx. Verify that the related
23269 -- entity E subject to pragma SPARK_Mode is library-level.
23271 procedure Process_Body
(Decl
: Node_Id
);
23272 -- Verify the legality of pragma SPARK_Mode when it appears as the
23273 -- top of the body declarations of entry, package, protected unit,
23274 -- subprogram or task unit body denoted by Decl.
23276 procedure Process_Overloadable
(Decl
: Node_Id
);
23277 -- Verify the legality of pragma SPARK_Mode when it applies to an
23278 -- entry or [generic] subprogram declaration denoted by Decl.
23280 procedure Process_Private_Part
(Decl
: Node_Id
);
23281 -- Verify the legality of pragma SPARK_Mode when it appears at the
23282 -- top of the private declarations of a package spec, protected or
23283 -- task unit declaration denoted by Decl.
23285 procedure Process_Statement_Part
(Decl
: Node_Id
);
23286 -- Verify the legality of pragma SPARK_Mode when it appears at the
23287 -- top of the statement sequence of a package body denoted by node
23290 procedure Process_Visible_Part
(Decl
: Node_Id
);
23291 -- Verify the legality of pragma SPARK_Mode when it appears at the
23292 -- top of the visible declarations of a package spec, protected or
23293 -- task unit declaration denoted by Decl. The routine is also used
23294 -- on protected or task units declared without a definition.
23296 procedure Set_SPARK_Context
;
23297 -- Subsidiary to routines Process_xxx. Set the global variables
23298 -- which represent the mode of the context from pragma N. Ensure
23299 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23301 ------------------------------
23302 -- Check_Pragma_Conformance --
23303 ------------------------------
23305 procedure Check_Pragma_Conformance
23306 (Context_Pragma
: Node_Id
;
23307 Entity
: Entity_Id
;
23308 Entity_Pragma
: Node_Id
)
23310 Err_Id
: Entity_Id
;
23314 -- The current pragma may appear without an argument. If this
23315 -- is the case, associate all error messages with the pragma
23318 if Present
(Arg1
) then
23324 -- The mode of the current pragma is compared against that of
23325 -- an enclosing context.
23327 if Present
(Context_Pragma
) then
23328 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
23330 -- Issue an error if the new mode is less restrictive than
23331 -- that of the context.
23333 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
23334 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23337 ("cannot change SPARK_Mode from Off to On", Err_N
);
23338 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
23339 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
23344 -- The mode of the current pragma is compared against that of
23345 -- an initial package, protected type, subprogram or task type
23348 if Present
(Entity
) then
23350 -- A simple protected or task type is transformed into an
23351 -- anonymous type whose name cannot be used to issue error
23352 -- messages. Recover the original entity of the type.
23354 if Ekind
(Entity
) in E_Protected_Type | E_Task_Type
then
23357 (Original_Node
(Unit_Declaration_Node
(Entity
)));
23362 -- Both the initial declaration and the completion carry
23363 -- SPARK_Mode pragmas.
23365 if Present
(Entity_Pragma
) then
23366 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
23368 -- Issue an error if the new mode is less restrictive
23369 -- than that of the initial declaration.
23371 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
23372 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23374 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23375 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
23377 ("\value Off was set for SPARK_Mode on&#",
23382 -- Otherwise the initial declaration lacks a SPARK_Mode
23383 -- pragma in which case the current pragma is illegal as
23384 -- it cannot "complete".
23386 elsif Get_SPARK_Mode_From_Annotation
(N
) = Off
23387 and then (Is_Generic_Unit
(Entity
) or else In_Instance
)
23392 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23393 Error_Msg_Sloc
:= Sloc
(Err_Id
);
23395 ("\no value was set for SPARK_Mode on&#",
23400 end Check_Pragma_Conformance
;
23402 --------------------------------
23403 -- Check_Library_Level_Entity --
23404 --------------------------------
23406 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
23407 procedure Add_Entity_To_Name_Buffer
;
23408 -- Add the E_Kind of entity E to the name buffer
23410 -------------------------------
23411 -- Add_Entity_To_Name_Buffer --
23412 -------------------------------
23414 procedure Add_Entity_To_Name_Buffer
is
23416 if Ekind
(E
) in E_Entry | E_Entry_Family
then
23417 Add_Str_To_Name_Buffer
("entry");
23419 elsif Ekind
(E
) in E_Generic_Package
23423 Add_Str_To_Name_Buffer
("package");
23425 elsif Ekind
(E
) in E_Protected_Body | E_Protected_Type
then
23426 Add_Str_To_Name_Buffer
("protected type");
23428 elsif Ekind
(E
) in E_Function
23429 | E_Generic_Function
23430 | E_Generic_Procedure
23432 | E_Subprogram_Body
23434 Add_Str_To_Name_Buffer
("subprogram");
23437 pragma Assert
(Ekind
(E
) in E_Task_Body | E_Task_Type
);
23438 Add_Str_To_Name_Buffer
("task type");
23440 end Add_Entity_To_Name_Buffer
;
23444 Msg_1
: constant String := "incorrect placement of pragma%";
23447 -- Start of processing for Check_Library_Level_Entity
23450 -- A SPARK_Mode of On shall only apply to library-level
23451 -- entities, except for those in generic instances, which are
23452 -- ignored (even if the entity gets SPARK_Mode pragma attached
23453 -- in the AST, its effect is not taken into account unless the
23454 -- context already provides SPARK_Mode of On in GNATprove).
23456 if Get_SPARK_Mode_From_Annotation
(N
) = On
23457 and then not Is_Library_Level_Entity
(E
)
23458 and then Instantiation_Location
(Sloc
(N
)) = No_Location
23460 Error_Msg_Name_1
:= Pname
;
23461 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
23464 Add_Str_To_Name_Buffer
("\& is not a library-level ");
23465 Add_Entity_To_Name_Buffer
;
23467 Msg_2
:= Name_Find
;
23468 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
23472 end Check_Library_Level_Entity
;
23478 procedure Process_Body
(Decl
: Node_Id
) is
23479 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23480 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
23483 -- Ignore pragma when applied to the special body created for
23484 -- inlining, recognized by its internal name _Parent.
23486 if Chars
(Body_Id
) = Name_uParent
then
23490 Check_Library_Level_Entity
(Body_Id
);
23492 -- For entry bodies, verify the legality against:
23493 -- * The mode of the context
23494 -- * The mode of the spec (if any)
23496 if Nkind
(Decl
) in N_Entry_Body | N_Subprogram_Body
then
23498 -- A stand-alone subprogram body
23500 if Body_Id
= Spec_Id
then
23501 Check_Pragma_Conformance
23502 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23504 Entity_Pragma
=> Empty
);
23506 -- An entry or subprogram body that completes a previous
23510 Check_Pragma_Conformance
23511 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23513 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23517 Set_SPARK_Pragma
(Body_Id
, N
);
23518 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23520 -- For package bodies, verify the legality against:
23521 -- * The mode of the context
23522 -- * The mode of the private part
23524 -- This case is separated from protected and task bodies
23525 -- because the statement part of the package body inherits
23526 -- the mode of the body declarations.
23528 elsif Nkind
(Decl
) = N_Package_Body
then
23529 Check_Pragma_Conformance
23530 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23532 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23535 Set_SPARK_Pragma
(Body_Id
, N
);
23536 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23537 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23538 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
23540 -- For protected and task bodies, verify the legality against:
23541 -- * The mode of the context
23542 -- * The mode of the private part
23546 (Nkind
(Decl
) in N_Protected_Body | N_Task_Body
);
23548 Check_Pragma_Conformance
23549 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23551 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23554 Set_SPARK_Pragma
(Body_Id
, N
);
23555 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23559 --------------------------
23560 -- Process_Overloadable --
23561 --------------------------
23563 procedure Process_Overloadable
(Decl
: Node_Id
) is
23564 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23565 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
23568 Check_Library_Level_Entity
(Spec_Id
);
23570 -- Verify the legality against:
23571 -- * The mode of the context
23573 Check_Pragma_Conformance
23574 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23576 Entity_Pragma
=> Empty
);
23578 Set_SPARK_Pragma
(Spec_Id
, N
);
23579 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23581 -- When the pragma applies to the anonymous object created for
23582 -- a single task type, decorate the type as well. This scenario
23583 -- arises when the single task type lacks a task definition,
23584 -- therefore there is no issue with respect to a potential
23585 -- pragma SPARK_Mode in the private part.
23587 -- task type Anon_Task_Typ;
23588 -- Obj : Anon_Task_Typ;
23589 -- pragma SPARK_Mode ...;
23591 if Is_Single_Task_Object
(Spec_Id
) then
23592 Set_SPARK_Pragma
(Spec_Typ
, N
);
23593 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
23594 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
23595 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
23597 end Process_Overloadable
;
23599 --------------------------
23600 -- Process_Private_Part --
23601 --------------------------
23603 procedure Process_Private_Part
(Decl
: Node_Id
) is
23604 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23607 Check_Library_Level_Entity
(Spec_Id
);
23609 -- Verify the legality against:
23610 -- * The mode of the visible declarations
23612 Check_Pragma_Conformance
23613 (Context_Pragma
=> Empty
,
23615 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23618 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23619 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
23620 end Process_Private_Part
;
23622 ----------------------------
23623 -- Process_Statement_Part --
23624 ----------------------------
23626 procedure Process_Statement_Part
(Decl
: Node_Id
) is
23627 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23630 Check_Library_Level_Entity
(Body_Id
);
23632 -- Verify the legality against:
23633 -- * The mode of the body declarations
23635 Check_Pragma_Conformance
23636 (Context_Pragma
=> Empty
,
23638 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
23641 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23642 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
23643 end Process_Statement_Part
;
23645 --------------------------
23646 -- Process_Visible_Part --
23647 --------------------------
23649 procedure Process_Visible_Part
(Decl
: Node_Id
) is
23650 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23651 Obj_Id
: Entity_Id
;
23654 Check_Library_Level_Entity
(Spec_Id
);
23656 -- Verify the legality against:
23657 -- * The mode of the context
23659 Check_Pragma_Conformance
23660 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23662 Entity_Pragma
=> Empty
);
23664 -- A task unit declared without a definition does not set the
23665 -- SPARK_Mode of the context because the task does not have any
23666 -- entries that could inherit the mode.
23668 if Nkind
(Decl
) not in
23669 N_Single_Task_Declaration | N_Task_Type_Declaration
23674 Set_SPARK_Pragma
(Spec_Id
, N
);
23675 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23676 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23677 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
23679 -- When the pragma applies to a single protected or task type,
23680 -- decorate the corresponding anonymous object as well.
23682 -- protected Anon_Prot_Typ is
23683 -- pragma SPARK_Mode ...;
23685 -- end Anon_Prot_Typ;
23687 -- Obj : Anon_Prot_Typ;
23689 if Is_Single_Concurrent_Type
(Spec_Id
) then
23690 Obj_Id
:= Anonymous_Object
(Spec_Id
);
23692 Set_SPARK_Pragma
(Obj_Id
, N
);
23693 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
23695 end Process_Visible_Part
;
23697 -----------------------
23698 -- Set_SPARK_Context --
23699 -----------------------
23701 procedure Set_SPARK_Context
is
23703 SPARK_Mode
:= Mode_Id
;
23704 SPARK_Mode_Pragma
:= N
;
23705 end Set_SPARK_Context
;
23713 -- Start of processing for Do_SPARK_Mode
23717 Check_No_Identifiers
;
23718 Check_At_Most_N_Arguments
(1);
23720 -- Check the legality of the mode (no argument = ON)
23722 if Arg_Count
= 1 then
23723 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23724 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
23729 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
23730 Context
:= Parent
(N
);
23732 -- When a SPARK_Mode pragma appears inside an instantiation whose
23733 -- enclosing context has SPARK_Mode set to "off", the pragma has
23734 -- no semantic effect.
23736 if Ignore_SPARK_Mode_Pragmas_In_Instance
23737 and then Mode_Id
/= Off
23739 Rewrite
(N
, Make_Null_Statement
(Loc
));
23744 -- The pragma appears in a configuration file
23746 if No
(Context
) then
23747 Check_Valid_Configuration_Pragma
;
23749 if Present
(SPARK_Mode_Pragma
) then
23752 Prev
=> SPARK_Mode_Pragma
);
23758 -- The pragma acts as a configuration pragma in a compilation unit
23760 -- pragma SPARK_Mode ...;
23761 -- package Pack is ...;
23763 elsif Nkind
(Context
) = N_Compilation_Unit
23764 and then List_Containing
(N
) = Context_Items
(Context
)
23766 Check_Valid_Configuration_Pragma
;
23769 -- Otherwise the placement of the pragma within the tree dictates
23770 -- its associated construct. Inspect the declarative list where
23771 -- the pragma resides to find a potential construct.
23775 while Present
(Stmt
) loop
23777 -- Skip prior pragmas, but check for duplicates. Note that
23778 -- this also takes care of pragmas generated for aspects.
23780 if Nkind
(Stmt
) = N_Pragma
then
23781 if Pragma_Name
(Stmt
) = Pname
then
23788 -- The pragma applies to an expression function that has
23789 -- already been rewritten into a subprogram declaration.
23791 -- function Expr_Func return ... is (...);
23792 -- pragma SPARK_Mode ...;
23794 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
23795 and then Nkind
(Original_Node
(Stmt
)) =
23796 N_Expression_Function
23798 Process_Overloadable
(Stmt
);
23801 -- The pragma applies to the anonymous object created for a
23802 -- single concurrent type.
23804 -- protected type Anon_Prot_Typ ...;
23805 -- Obj : Anon_Prot_Typ;
23806 -- pragma SPARK_Mode ...;
23808 elsif Nkind
(Stmt
) = N_Object_Declaration
23809 and then Is_Single_Concurrent_Object
23810 (Defining_Entity
(Stmt
))
23812 Process_Overloadable
(Stmt
);
23815 -- Skip internally generated code
23817 elsif not Comes_From_Source
(Stmt
) then
23820 -- The pragma applies to an entry or [generic] subprogram
23824 -- pragma SPARK_Mode ...;
23827 -- procedure Proc ...;
23828 -- pragma SPARK_Mode ...;
23830 elsif Nkind
(Stmt
) in N_Generic_Subprogram_Declaration
23831 | N_Subprogram_Declaration
23832 or else (Nkind
(Stmt
) = N_Entry_Declaration
23833 and then Is_Protected_Type
23834 (Scope
(Defining_Entity
(Stmt
))))
23836 Process_Overloadable
(Stmt
);
23839 -- Otherwise the pragma does not apply to a legal construct
23840 -- or it does not appear at the top of a declarative or a
23841 -- statement list. Issue an error and stop the analysis.
23851 -- The pragma applies to a package or a subprogram that acts as
23852 -- a compilation unit.
23854 -- procedure Proc ...;
23855 -- pragma SPARK_Mode ...;
23857 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
23858 Context
:= Unit
(Parent
(Context
));
23861 -- The pragma appears at the top of entry, package, protected
23862 -- unit, subprogram or task unit body declarations.
23864 -- entry Ent when ... is
23865 -- pragma SPARK_Mode ...;
23867 -- package body Pack is
23868 -- pragma SPARK_Mode ...;
23870 -- procedure Proc ... is
23871 -- pragma SPARK_Mode;
23873 -- protected body Prot is
23874 -- pragma SPARK_Mode ...;
23876 if Nkind
(Context
) in N_Entry_Body
23879 | N_Subprogram_Body
23882 Process_Body
(Context
);
23884 -- The pragma appears at the top of the visible or private
23885 -- declaration of a package spec, protected or task unit.
23888 -- pragma SPARK_Mode ...;
23890 -- pragma SPARK_Mode ...;
23892 -- protected [type] Prot is
23893 -- pragma SPARK_Mode ...;
23895 -- pragma SPARK_Mode ...;
23897 elsif Nkind
(Context
) in N_Package_Specification
23898 | N_Protected_Definition
23899 | N_Task_Definition
23901 if List_Containing
(N
) = Visible_Declarations
(Context
) then
23902 Process_Visible_Part
(Parent
(Context
));
23904 Process_Private_Part
(Parent
(Context
));
23907 -- The pragma appears at the top of package body statements
23909 -- package body Pack is
23911 -- pragma SPARK_Mode;
23913 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
23914 and then Nkind
(Parent
(Context
)) = N_Package_Body
23916 Process_Statement_Part
(Parent
(Context
));
23918 -- The pragma appeared as an aspect of a [generic] subprogram
23919 -- declaration that acts as a compilation unit.
23922 -- procedure Proc ...;
23923 -- pragma SPARK_Mode ...;
23925 elsif Nkind
(Context
) in N_Generic_Subprogram_Declaration
23926 | N_Subprogram_Declaration
23928 Process_Overloadable
(Context
);
23930 -- The pragma does not apply to a legal construct, issue error
23938 --------------------------------
23939 -- Static_Elaboration_Desired --
23940 --------------------------------
23942 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23944 when Pragma_Static_Elaboration_Desired
=>
23946 Check_At_Most_N_Arguments
(1);
23948 if Is_Compilation_Unit
(Current_Scope
)
23949 and then Ekind
(Current_Scope
) = E_Package
23951 Set_Static_Elaboration_Desired
(Current_Scope
, True);
23953 Error_Pragma
("pragma% must apply to a library-level package");
23960 -- pragma Storage_Size (EXPRESSION);
23962 when Pragma_Storage_Size
=> Storage_Size
: declare
23963 P
: constant Node_Id
:= Parent
(N
);
23967 Check_No_Identifiers
;
23968 Check_Arg_Count
(1);
23970 -- The expression must be analyzed in the special manner described
23971 -- in "Handling of Default Expressions" in sem.ads.
23973 Arg
:= Get_Pragma_Arg
(Arg1
);
23974 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23976 if not Is_OK_Static_Expression
(Arg
) then
23977 Check_Restriction
(Static_Storage_Size
, Arg
);
23980 if Nkind
(P
) /= N_Task_Definition
then
23985 if Has_Storage_Size_Pragma
(P
) then
23986 Error_Pragma
("duplicate pragma% not allowed");
23988 Set_Has_Storage_Size_Pragma
(P
, True);
23991 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
23999 -- pragma Storage_Unit (NUMERIC_LITERAL);
24001 -- Only permitted argument is System'Storage_Unit value
24003 when Pragma_Storage_Unit
=>
24004 Check_No_Identifiers
;
24005 Check_Arg_Count
(1);
24006 Check_Arg_Is_Integer_Literal
(Arg1
);
24008 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
24009 UI_From_Int
(Ttypes
.System_Storage_Unit
)
24011 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
24013 ("the only allowed argument for pragma% is ^", Arg1
);
24016 --------------------
24017 -- Stream_Convert --
24018 --------------------
24020 -- pragma Stream_Convert (
24021 -- [Entity =>] type_LOCAL_NAME,
24022 -- [Read =>] function_NAME,
24023 -- [Write =>] function NAME);
24025 when Pragma_Stream_Convert
=> Stream_Convert
: declare
24026 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
24027 -- Check that the given argument is the name of a local function
24028 -- of one argument that is not overloaded earlier in the current
24029 -- local scope. A check is also made that the argument is a
24030 -- function with one parameter.
24032 --------------------------------------
24033 -- Check_OK_Stream_Convert_Function --
24034 --------------------------------------
24036 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
24040 Check_Arg_Is_Local_Name
(Arg
);
24041 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
24043 if Has_Homonym
(Ent
) then
24045 ("argument for pragma% may not be overloaded", Arg
);
24048 if Ekind
(Ent
) /= E_Function
24049 or else No
(First_Formal
(Ent
))
24050 or else Present
(Next_Formal
(First_Formal
(Ent
)))
24053 ("argument for pragma% must be function of one argument",
24055 elsif Is_Abstract_Subprogram
(Ent
) then
24057 ("argument for pragma% cannot be abstract", Arg
);
24059 end Check_OK_Stream_Convert_Function
;
24061 -- Start of processing for Stream_Convert
24065 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
24066 Check_Arg_Count
(3);
24067 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24068 Check_Optional_Identifier
(Arg2
, Name_Read
);
24069 Check_Optional_Identifier
(Arg3
, Name_Write
);
24070 Check_Arg_Is_Local_Name
(Arg1
);
24071 Check_OK_Stream_Convert_Function
(Arg2
);
24072 Check_OK_Stream_Convert_Function
(Arg3
);
24075 Typ
: constant Entity_Id
:=
24076 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
24077 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
24078 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
24081 Check_First_Subtype
(Arg1
);
24083 -- Check for too early or too late. Note that we don't enforce
24084 -- the rule about primitive operations in this case, since, as
24085 -- is the case for explicit stream attributes themselves, these
24086 -- restrictions are not appropriate. Note that the chaining of
24087 -- the pragma by Rep_Item_Too_Late is actually the critical
24088 -- processing done for this pragma.
24090 if Rep_Item_Too_Early
(Typ
, N
)
24092 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
24097 -- Return if previous error
24099 if Etype
(Typ
) = Any_Type
24101 Etype
(Read
) = Any_Type
24103 Etype
(Write
) = Any_Type
24110 if Underlying_Type
(Etype
(Read
)) /= Typ
then
24112 ("incorrect return type for function&", Arg2
);
24115 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
24117 ("incorrect parameter type for function&", Arg3
);
24120 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
24121 Underlying_Type
(Etype
(Write
))
24124 ("result type of & does not match Read parameter type",
24128 end Stream_Convert
;
24134 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24136 -- This is processed by the parser since some of the style checks
24137 -- take place during source scanning and parsing. This means that
24138 -- we don't need to issue error messages here.
24140 when Pragma_Style_Checks
=> Style_Checks
: declare
24141 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
24147 Check_No_Identifiers
;
24149 -- Two argument form
24151 if Arg_Count
= 2 then
24152 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
24159 E_Id
:= Get_Pragma_Arg
(Arg2
);
24162 if not Is_Entity_Name
(E_Id
) then
24164 ("second argument of pragma% must be entity name",
24168 E
:= Entity
(E_Id
);
24170 if not Ignore_Style_Checks_Pragmas
then
24175 Set_Suppress_Style_Checks
24176 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
24177 exit when No
(Homonym
(E
));
24184 -- One argument form
24187 Check_Arg_Count
(1);
24189 if Nkind
(A
) = N_String_Literal
then
24193 Slen
: constant Natural := Natural (String_Length
(S
));
24194 Options
: String (1 .. Slen
);
24200 C
:= Get_String_Char
(S
, Pos
(J
));
24201 exit when not In_Character_Range
(C
);
24202 Options
(J
) := Get_Character
(C
);
24204 -- If at end of string, set options. As per discussion
24205 -- above, no need to check for errors, since we issued
24206 -- them in the parser.
24209 if not Ignore_Style_Checks_Pragmas
then
24210 Set_Style_Check_Options
(Options
);
24220 elsif Nkind
(A
) = N_Identifier
then
24221 if Chars
(A
) = Name_All_Checks
then
24222 if not Ignore_Style_Checks_Pragmas
then
24224 Set_GNAT_Style_Check_Options
;
24226 Set_Default_Style_Check_Options
;
24230 elsif Chars
(A
) = Name_On
then
24231 if not Ignore_Style_Checks_Pragmas
then
24232 Style_Check
:= True;
24235 elsif Chars
(A
) = Name_Off
then
24236 if not Ignore_Style_Checks_Pragmas
then
24237 Style_Check
:= False;
24244 ------------------------
24245 -- Subprogram_Variant --
24246 ------------------------
24248 -- pragma Subprogram_Variant ( SUBPROGRAM_VARIANT_ITEM
24249 -- {, SUBPROGRAM_VARIANT_ITEM } );
24251 -- SUBPROGRAM_VARIANT_ITEM ::=
24252 -- CHANGE_DIRECTION => discrete_EXPRESSION
24254 -- CHANGE_DIRECTION ::= Increases | Decreases
24256 -- Characteristics:
24258 -- * Analysis - The annotation undergoes initial checks to verify
24259 -- the legal placement and context. Secondary checks preanalyze the
24262 -- Analyze_Subprogram_Variant_In_Decl_Part
24264 -- * Expansion - The annotation is expanded during the expansion of
24265 -- the related subprogram [body] contract as performed in:
24267 -- Expand_Subprogram_Contract
24269 -- * Template - The annotation utilizes the generic template of the
24270 -- related subprogram [body] when it is:
24272 -- aspect on subprogram declaration
24273 -- aspect on stand-alone subprogram body
24274 -- pragma on stand-alone subprogram body
24276 -- The annotation must prepare its own template when it is:
24278 -- pragma on subprogram declaration
24280 -- * Globals - Capture of global references must occur after full
24283 -- * Instance - The annotation is instantiated automatically when
24284 -- the related generic subprogram [body] is instantiated except for
24285 -- the "pragma on subprogram declaration" case. In that scenario
24286 -- the annotation must instantiate itself.
24288 when Pragma_Subprogram_Variant
=> Subprogram_Variant
: declare
24289 Spec_Id
: Entity_Id
;
24290 Subp_Decl
: Node_Id
;
24291 Subp_Spec
: Node_Id
;
24295 Check_No_Identifiers
;
24296 Check_Arg_Count
(1);
24298 -- Ensure the proper placement of the pragma. Subprogram_Variant
24299 -- must be associated with a subprogram declaration or a body that
24303 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
24305 -- Generic subprogram
24307 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
24310 -- Body acts as spec
24312 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
24313 and then No
(Corresponding_Spec
(Subp_Decl
))
24317 -- Body stub acts as spec
24319 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24320 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24326 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
24327 Subp_Spec
:= Specification
(Subp_Decl
);
24329 -- Pragma Subprogram_Variant is forbidden on null procedures,
24330 -- as this may lead to potential ambiguities in behavior when
24331 -- interface null procedures are involved. Also, it just
24332 -- wouldn't make sense, because null procedure is not
24335 if Nkind
(Subp_Spec
) = N_Procedure_Specification
24336 and then Null_Present
(Subp_Spec
)
24338 Error_Msg_N
(Fix_Error
24339 ("pragma % cannot apply to null procedure"), N
);
24348 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
24350 -- A pragma that applies to a Ghost entity becomes Ghost for the
24351 -- purposes of legality checks and removal of ignored Ghost code.
24353 Mark_Ghost_Pragma
(N
, Spec_Id
);
24354 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
24356 -- Chain the pragma on the contract for further processing by
24357 -- Analyze_Subprogram_Variant_In_Decl_Part.
24359 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
24361 -- Fully analyze the pragma when it appears inside a subprogram
24362 -- body because it cannot benefit from forward references.
24364 if Nkind
(Subp_Decl
) in N_Subprogram_Body
24365 | N_Subprogram_Body_Stub
24367 -- The legality checks of pragma Subprogram_Variant are
24368 -- affected by the SPARK mode in effect and the volatility
24369 -- of the context. Analyze all pragmas in a specific order.
24371 Analyze_If_Present
(Pragma_SPARK_Mode
);
24372 Analyze_If_Present
(Pragma_Volatile_Function
);
24373 Analyze_Subprogram_Variant_In_Decl_Part
(N
);
24375 end Subprogram_Variant
;
24381 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
24383 when Pragma_Subtitle
=>
24385 Check_Arg_Count
(1);
24386 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
24387 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24394 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
24396 when Pragma_Suppress
=>
24397 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
24403 -- pragma Suppress_All;
24405 -- The only check made here is that the pragma has no arguments.
24406 -- There are no placement rules, and the processing required (setting
24407 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
24408 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
24409 -- then creates and inserts a pragma Suppress (All_Checks).
24411 when Pragma_Suppress_All
=>
24413 Check_Arg_Count
(0);
24415 -------------------------
24416 -- Suppress_Debug_Info --
24417 -------------------------
24419 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24421 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
24422 Nam_Id
: Entity_Id
;
24426 Check_Arg_Count
(1);
24427 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24428 Check_Arg_Is_Local_Name
(Arg1
);
24430 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
24432 -- A pragma that applies to a Ghost entity becomes Ghost for the
24433 -- purposes of legality checks and removal of ignored Ghost code.
24435 Mark_Ghost_Pragma
(N
, Nam_Id
);
24436 Set_Debug_Info_Off
(Nam_Id
);
24437 end Suppress_Debug_Info
;
24439 ----------------------------------
24440 -- Suppress_Exception_Locations --
24441 ----------------------------------
24443 -- pragma Suppress_Exception_Locations;
24445 when Pragma_Suppress_Exception_Locations
=>
24447 Check_Arg_Count
(0);
24448 Check_Valid_Configuration_Pragma
;
24449 Exception_Locations_Suppressed
:= True;
24451 -----------------------------
24452 -- Suppress_Initialization --
24453 -----------------------------
24455 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24457 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
24463 Check_Arg_Count
(1);
24464 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24465 Check_Arg_Is_Local_Name
(Arg1
);
24467 E_Id
:= Get_Pragma_Arg
(Arg1
);
24469 if Etype
(E_Id
) = Any_Type
then
24473 E
:= Entity
(E_Id
);
24475 -- A pragma that applies to a Ghost entity becomes Ghost for the
24476 -- purposes of legality checks and removal of ignored Ghost code.
24478 Mark_Ghost_Pragma
(N
, E
);
24480 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
24482 ("pragma% requires variable, type or subtype", Arg1
);
24485 if Rep_Item_Too_Early
(E
, N
)
24487 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
24492 -- For incomplete/private type, set flag on full view
24494 if Is_Incomplete_Or_Private_Type
(E
) then
24495 if No
(Full_View
(Base_Type
(E
))) then
24497 ("argument of pragma% cannot be an incomplete type", Arg1
);
24499 Set_Suppress_Initialization
(Full_View
(E
));
24502 -- For first subtype, set flag on base type
24504 elsif Is_First_Subtype
(E
) then
24505 Set_Suppress_Initialization
(Base_Type
(E
));
24507 -- For other than first subtype, set flag on subtype or variable
24510 Set_Suppress_Initialization
(E
);
24518 -- pragma System_Name (DIRECT_NAME);
24520 -- Syntax check: one argument, which must be the identifier GNAT or
24521 -- the identifier GCC, no other identifiers are acceptable.
24523 when Pragma_System_Name
=>
24525 Check_No_Identifiers
;
24526 Check_Arg_Count
(1);
24527 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
24529 -----------------------------
24530 -- Task_Dispatching_Policy --
24531 -----------------------------
24533 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24535 when Pragma_Task_Dispatching_Policy
=> declare
24539 Check_Ada_83_Warning
;
24540 Check_Arg_Count
(1);
24541 Check_No_Identifiers
;
24542 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
24543 Check_Valid_Configuration_Pragma
;
24544 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24545 DP
:= Fold_Upper
(Name_Buffer
(1));
24547 if Task_Dispatching_Policy
/= ' '
24548 and then Task_Dispatching_Policy
/= DP
24550 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
24552 ("task dispatching policy incompatible with policy#");
24554 -- Set new policy, but always preserve System_Location since we
24555 -- like the error message with the run time name.
24558 Task_Dispatching_Policy
:= DP
;
24560 if Task_Dispatching_Policy_Sloc
/= System_Location
then
24561 Task_Dispatching_Policy_Sloc
:= Loc
;
24570 -- pragma Task_Info (EXPRESSION);
24572 when Pragma_Task_Info
=> Task_Info
: declare
24573 P
: constant Node_Id
:= Parent
(N
);
24579 if Warn_On_Obsolescent_Feature
then
24581 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24582 & "instead?j?", N
);
24585 if Nkind
(P
) /= N_Task_Definition
then
24586 Error_Pragma
("pragma% must appear in task definition");
24589 Check_No_Identifiers
;
24590 Check_Arg_Count
(1);
24592 Analyze_And_Resolve
24593 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
24595 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
24599 Ent
:= Defining_Identifier
(Parent
(P
));
24601 -- Check duplicate pragma before we chain the pragma in the Rep
24602 -- Item chain of Ent.
24605 (Ent
, Name_Task_Info
, Check_Parents
=> False)
24607 Error_Pragma
("duplicate pragma% not allowed");
24610 Record_Rep_Item
(Ent
, N
);
24617 -- pragma Task_Name (string_EXPRESSION);
24619 when Pragma_Task_Name
=> Task_Name
: declare
24620 P
: constant Node_Id
:= Parent
(N
);
24625 Check_No_Identifiers
;
24626 Check_Arg_Count
(1);
24628 Arg
:= Get_Pragma_Arg
(Arg1
);
24630 -- The expression is used in the call to Create_Task, and must be
24631 -- expanded there, not in the context of the current spec. It must
24632 -- however be analyzed to capture global references, in case it
24633 -- appears in a generic context.
24635 Preanalyze_And_Resolve
(Arg
, Standard_String
);
24637 if Nkind
(P
) /= N_Task_Definition
then
24641 Ent
:= Defining_Identifier
(Parent
(P
));
24643 -- Check duplicate pragma before we chain the pragma in the Rep
24644 -- Item chain of Ent.
24647 (Ent
, Name_Task_Name
, Check_Parents
=> False)
24649 Error_Pragma
("duplicate pragma% not allowed");
24652 Record_Rep_Item
(Ent
, N
);
24659 -- pragma Task_Storage (
24660 -- [Task_Type =>] LOCAL_NAME,
24661 -- [Top_Guard =>] static_integer_EXPRESSION);
24663 when Pragma_Task_Storage
=> Task_Storage
: declare
24664 Args
: Args_List
(1 .. 2);
24665 Names
: constant Name_List
(1 .. 2) := (
24669 Task_Type
: Node_Id
renames Args
(1);
24670 Top_Guard
: Node_Id
renames Args
(2);
24676 Gather_Associations
(Names
, Args
);
24678 if No
(Task_Type
) then
24680 ("missing task_type argument for pragma%");
24683 Check_Arg_Is_Local_Name
(Task_Type
);
24685 Ent
:= Entity
(Task_Type
);
24687 if not Is_Task_Type
(Ent
) then
24689 ("argument for pragma% must be task type", Task_Type
);
24692 if No
(Top_Guard
) then
24694 ("pragma% takes two arguments", Task_Type
);
24696 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
24699 Check_First_Subtype
(Task_Type
);
24701 if Rep_Item_Too_Late
(Ent
, N
) then
24710 -- pragma Test_Case
24711 -- ([Name =>] Static_String_EXPRESSION
24712 -- ,[Mode =>] MODE_TYPE
24713 -- [, Requires => Boolean_EXPRESSION]
24714 -- [, Ensures => Boolean_EXPRESSION]);
24716 -- MODE_TYPE ::= Nominal | Robustness
24718 -- Characteristics:
24720 -- * Analysis - The annotation undergoes initial checks to verify
24721 -- the legal placement and context. Secondary checks preanalyze the
24724 -- Analyze_Test_Case_In_Decl_Part
24726 -- * Expansion - None.
24728 -- * Template - The annotation utilizes the generic template of the
24729 -- related subprogram when it is:
24731 -- aspect on subprogram declaration
24733 -- The annotation must prepare its own template when it is:
24735 -- pragma on subprogram declaration
24737 -- * Globals - Capture of global references must occur after full
24740 -- * Instance - The annotation is instantiated automatically when
24741 -- the related generic subprogram is instantiated except for the
24742 -- "pragma on subprogram declaration" case. In that scenario the
24743 -- annotation must instantiate itself.
24745 when Pragma_Test_Case
=> Test_Case
: declare
24746 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
24747 -- Ensure that the contract of subprogram Subp_Id does not contain
24748 -- another Test_Case pragma with the same Name as the current one.
24750 -------------------------
24751 -- Check_Distinct_Name --
24752 -------------------------
24754 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
24755 Items
: constant Node_Id
:= Contract
(Subp_Id
);
24756 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
24760 -- Inspect all Test_Case pragma of the related subprogram
24761 -- looking for one with a duplicate "Name" argument.
24763 if Present
(Items
) then
24764 Prag
:= Contract_Test_Cases
(Items
);
24765 while Present
(Prag
) loop
24766 if Pragma_Name
(Prag
) = Name_Test_Case
24768 and then String_Equal
24769 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
24771 Error_Msg_Sloc
:= Sloc
(Prag
);
24772 Error_Pragma
("name for pragma % is already used #");
24775 Prag
:= Next_Pragma
(Prag
);
24778 end Check_Distinct_Name
;
24782 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
24785 Subp_Decl
: Node_Id
;
24786 Subp_Id
: Entity_Id
;
24788 -- Start of processing for Test_Case
24792 Check_At_Least_N_Arguments
(2);
24793 Check_At_Most_N_Arguments
(4);
24795 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
24799 Check_Optional_Identifier
(Arg1
, Name_Name
);
24800 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24804 Check_Optional_Identifier
(Arg2
, Name_Mode
);
24805 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
24807 -- Arguments "Requires" and "Ensures"
24809 if Present
(Arg3
) then
24810 if Present
(Arg4
) then
24811 Check_Identifier
(Arg3
, Name_Requires
);
24812 Check_Identifier
(Arg4
, Name_Ensures
);
24814 Check_Identifier_Is_One_Of
24815 (Arg3
, Name_Requires
, Name_Ensures
);
24819 -- Pragma Test_Case must be associated with a subprogram declared
24820 -- in a library-level package. First determine whether the current
24821 -- compilation unit is a legal context.
24823 if Nkind
(Pack_Decl
) in N_Package_Declaration
24824 | N_Generic_Package_Declaration
24828 -- Otherwise the placement is illegal
24832 ("pragma % must be specified within a package declaration");
24836 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
24838 -- Find the enclosing context
24840 Context
:= Parent
(Subp_Decl
);
24842 if Present
(Context
) then
24843 Context
:= Parent
(Context
);
24846 -- Verify the placement of the pragma
24848 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
24850 ("pragma % cannot be applied to abstract subprogram");
24853 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
24854 Error_Pragma
("pragma % cannot be applied to entry");
24857 -- The context is a [generic] subprogram declared at the top level
24858 -- of the [generic] package unit.
24860 elsif Nkind
(Subp_Decl
) in N_Generic_Subprogram_Declaration
24861 | N_Subprogram_Declaration
24862 and then Present
(Context
)
24863 and then Nkind
(Context
) in N_Generic_Package_Declaration
24864 | N_Package_Declaration
24868 -- Otherwise the placement is illegal
24872 ("pragma % must be applied to a library-level subprogram "
24877 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24879 -- A pragma that applies to a Ghost entity becomes Ghost for the
24880 -- purposes of legality checks and removal of ignored Ghost code.
24882 Mark_Ghost_Pragma
(N
, Subp_Id
);
24884 -- Chain the pragma on the contract for further processing by
24885 -- Analyze_Test_Case_In_Decl_Part.
24887 Add_Contract_Item
(N
, Subp_Id
);
24889 -- Preanalyze the original aspect argument "Name" for a generic
24890 -- subprogram to properly capture global references.
24892 if Is_Generic_Subprogram
(Subp_Id
) then
24893 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
24895 if Present
(Asp_Arg
) then
24897 -- The argument appears with an identifier in association
24900 if Nkind
(Asp_Arg
) = N_Component_Association
then
24901 Asp_Arg
:= Expression
(Asp_Arg
);
24904 Check_Expr_Is_OK_Static_Expression
24905 (Asp_Arg
, Standard_String
);
24909 -- Ensure that the all Test_Case pragmas of the related subprogram
24910 -- have distinct names.
24912 Check_Distinct_Name
(Subp_Id
);
24914 -- Fully analyze the pragma when it appears inside an entry
24915 -- or subprogram body because it cannot benefit from forward
24918 if Nkind
(Subp_Decl
) in N_Entry_Body
24919 | N_Subprogram_Body
24920 | N_Subprogram_Body_Stub
24922 -- The legality checks of pragma Test_Case are affected by the
24923 -- SPARK mode in effect and the volatility of the context.
24924 -- Analyze all pragmas in a specific order.
24926 Analyze_If_Present
(Pragma_SPARK_Mode
);
24927 Analyze_If_Present
(Pragma_Volatile_Function
);
24928 Analyze_Test_Case_In_Decl_Part
(N
);
24932 --------------------------
24933 -- Thread_Local_Storage --
24934 --------------------------
24936 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24938 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
24944 Check_Arg_Count
(1);
24945 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24946 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24948 Id
:= Get_Pragma_Arg
(Arg1
);
24951 if not Is_Entity_Name
(Id
)
24952 or else Ekind
(Entity
(Id
)) /= E_Variable
24954 Error_Pragma_Arg
("local variable name required", Arg1
);
24959 -- A pragma that applies to a Ghost entity becomes Ghost for the
24960 -- purposes of legality checks and removal of ignored Ghost code.
24962 Mark_Ghost_Pragma
(N
, E
);
24964 if Rep_Item_Too_Early
(E
, N
)
24966 Rep_Item_Too_Late
(E
, N
)
24971 Set_Has_Pragma_Thread_Local_Storage
(E
);
24972 Set_Has_Gigi_Rep_Item
(E
);
24973 end Thread_Local_Storage
;
24979 -- pragma Time_Slice (static_duration_EXPRESSION);
24981 when Pragma_Time_Slice
=> Time_Slice
: declare
24987 Check_Arg_Count
(1);
24988 Check_No_Identifiers
;
24989 Check_In_Main_Program
;
24990 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
24992 if not Error_Posted
(Arg1
) then
24994 while Present
(Nod
) loop
24995 if Nkind
(Nod
) = N_Pragma
24996 and then Pragma_Name
(Nod
) = Name_Time_Slice
24998 Error_Msg_Name_1
:= Pname
;
24999 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
25006 -- Process only if in main unit
25008 if Get_Source_Unit
(Loc
) = Main_Unit
then
25009 Opt
.Time_Slice_Set
:= True;
25010 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
25012 if Val
<= Ureal_0
then
25013 Opt
.Time_Slice_Value
:= 0;
25015 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
25016 Opt
.Time_Slice_Value
:= 1_000_000_000
;
25019 Opt
.Time_Slice_Value
:=
25020 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
25029 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
25031 -- TITLING_OPTION ::=
25032 -- [Title =>] STRING_LITERAL
25033 -- | [Subtitle =>] STRING_LITERAL
25035 when Pragma_Title
=> Title
: declare
25036 Args
: Args_List
(1 .. 2);
25037 Names
: constant Name_List
(1 .. 2) := (
25043 Gather_Associations
(Names
, Args
);
25046 for J
in 1 .. 2 loop
25047 if Present
(Args
(J
)) then
25048 Check_Arg_Is_OK_Static_Expression
25049 (Args
(J
), Standard_String
);
25054 ----------------------------
25055 -- Type_Invariant[_Class] --
25056 ----------------------------
25058 -- pragma Type_Invariant[_Class]
25059 -- ([Entity =>] type_LOCAL_NAME,
25060 -- [Check =>] EXPRESSION);
25062 when Pragma_Type_Invariant
25063 | Pragma_Type_Invariant_Class
25065 Type_Invariant
: declare
25066 I_Pragma
: Node_Id
;
25069 Check_Arg_Count
(2);
25071 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
25072 -- setting Class_Present for the Type_Invariant_Class case.
25074 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
25075 I_Pragma
:= New_Copy
(N
);
25076 Set_Pragma_Identifier
25077 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
25078 Rewrite
(N
, I_Pragma
);
25079 Set_Analyzed
(N
, False);
25081 end Type_Invariant
;
25083 ---------------------
25084 -- Unchecked_Union --
25085 ---------------------
25087 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
25089 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
25090 Assoc
: constant Node_Id
:= Arg1
;
25091 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
25101 Check_No_Identifiers
;
25102 Check_Arg_Count
(1);
25103 Check_Arg_Is_Local_Name
(Arg1
);
25105 Find_Type
(Type_Id
);
25107 Typ
:= Entity
(Type_Id
);
25109 -- A pragma that applies to a Ghost entity becomes Ghost for the
25110 -- purposes of legality checks and removal of ignored Ghost code.
25112 Mark_Ghost_Pragma
(N
, Typ
);
25115 or else Rep_Item_Too_Early
(Typ
, N
)
25119 Typ
:= Underlying_Type
(Typ
);
25122 if Rep_Item_Too_Late
(Typ
, N
) then
25126 Check_First_Subtype
(Arg1
);
25128 -- Note remaining cases are references to a type in the current
25129 -- declarative part. If we find an error, we post the error on
25130 -- the relevant type declaration at an appropriate point.
25132 if not Is_Record_Type
(Typ
) then
25133 Error_Msg_N
("unchecked union must be record type", Typ
);
25136 elsif Is_Tagged_Type
(Typ
) then
25137 Error_Msg_N
("unchecked union must not be tagged", Typ
);
25140 elsif not Has_Discriminants
(Typ
) then
25142 ("unchecked union must have one discriminant", Typ
);
25145 -- Note: in previous versions of GNAT we used to check for limited
25146 -- types and give an error, but in fact the standard does allow
25147 -- Unchecked_Union on limited types, so this check was removed.
25149 -- Similarly, GNAT used to require that all discriminants have
25150 -- default values, but this is not mandated by the RM.
25152 -- Proceed with basic error checks completed
25155 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
25156 Clist
:= Component_List
(Tdef
);
25158 -- Check presence of component list and variant part
25160 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
25162 ("unchecked union must have variant part", Tdef
);
25166 -- Check components
25168 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
25169 while Present
(Comp
) loop
25170 Check_Component
(Comp
, Typ
);
25171 Next_Non_Pragma
(Comp
);
25174 -- Check variant part
25176 Vpart
:= Variant_Part
(Clist
);
25178 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
25179 while Present
(Variant
) loop
25180 Check_Variant
(Variant
, Typ
);
25181 Next_Non_Pragma
(Variant
);
25185 Set_Is_Unchecked_Union
(Typ
);
25186 Set_Convention
(Typ
, Convention_C
);
25187 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
25188 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
25189 end Unchecked_Union
;
25191 ----------------------------
25192 -- Unevaluated_Use_Of_Old --
25193 ----------------------------
25195 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
25197 when Pragma_Unevaluated_Use_Of_Old
=>
25199 Check_Arg_Count
(1);
25200 Check_No_Identifiers
;
25201 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
25203 -- Suppress/Unsuppress can appear as a configuration pragma, or in
25204 -- a declarative part or a package spec.
25206 if not Is_Configuration_Pragma
then
25207 Check_Is_In_Decl_Part_Or_Package_Spec
;
25210 -- Store proper setting of Uneval_Old
25212 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
25213 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
25215 ------------------------
25216 -- Unimplemented_Unit --
25217 ------------------------
25219 -- pragma Unimplemented_Unit;
25221 -- Note: this only gives an error if we are generating code, or if
25222 -- we are in a generic library unit (where the pragma appears in the
25223 -- body, not in the spec).
25225 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
25226 Cunitent
: constant Entity_Id
:=
25227 Cunit_Entity
(Get_Source_Unit
(Loc
));
25231 Check_Arg_Count
(0);
25233 if Operating_Mode
= Generate_Code
25234 or else Is_Generic_Unit
(Cunitent
)
25236 Get_Name_String
(Chars
(Cunitent
));
25237 Set_Casing
(Mixed_Case
);
25238 Write_Str
(Name_Buffer
(1 .. Name_Len
));
25239 Write_Str
(" is not supported in this configuration");
25241 raise Unrecoverable_Error
;
25243 end Unimplemented_Unit
;
25245 ------------------------
25246 -- Universal_Aliasing --
25247 ------------------------
25249 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
25251 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
25257 Check_Arg_Count
(1);
25258 Check_Optional_Identifier
(Arg2
, Name_Entity
);
25259 Check_Arg_Is_Local_Name
(Arg1
);
25260 E_Id
:= Get_Pragma_Arg
(Arg1
);
25262 if Etype
(E_Id
) = Any_Type
then
25266 E
:= Entity
(E_Id
);
25268 if not Is_Type
(E
) then
25269 Error_Pragma_Arg
("pragma% requires type", Arg1
);
25272 -- A pragma that applies to a Ghost entity becomes Ghost for the
25273 -- purposes of legality checks and removal of ignored Ghost code.
25275 Mark_Ghost_Pragma
(N
, E
);
25276 Set_Universal_Aliasing
(Base_Type
(E
));
25277 Record_Rep_Item
(E
, N
);
25278 end Universal_Alias
;
25284 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
25286 when Pragma_Unmodified
=>
25287 Analyze_Unmodified_Or_Unused
;
25293 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
25295 -- or when used in a context clause:
25297 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
25299 when Pragma_Unreferenced
=>
25300 Analyze_Unreferenced_Or_Unused
;
25302 --------------------------
25303 -- Unreferenced_Objects --
25304 --------------------------
25306 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
25308 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
25310 Arg_Expr
: Node_Id
;
25311 Arg_Id
: Entity_Id
;
25313 Ghost_Error_Posted
: Boolean := False;
25314 -- Flag set when an error concerning the illegal mix of Ghost and
25315 -- non-Ghost types is emitted.
25317 Ghost_Id
: Entity_Id
:= Empty
;
25318 -- The entity of the first Ghost type encountered while processing
25319 -- the arguments of the pragma.
25323 Check_At_Least_N_Arguments
(1);
25326 while Present
(Arg
) loop
25327 Check_No_Identifier
(Arg
);
25328 Check_Arg_Is_Local_Name
(Arg
);
25329 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
25331 if Is_Entity_Name
(Arg_Expr
) then
25332 Arg_Id
:= Entity
(Arg_Expr
);
25334 if Is_Type
(Arg_Id
) then
25335 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
25337 -- A pragma that applies to a Ghost entity becomes Ghost
25338 -- for the purposes of legality checks and removal of
25339 -- ignored Ghost code.
25341 Mark_Ghost_Pragma
(N
, Arg_Id
);
25343 -- Capture the entity of the first Ghost type being
25344 -- processed for error detection purposes.
25346 if Is_Ghost_Entity
(Arg_Id
) then
25347 if No
(Ghost_Id
) then
25348 Ghost_Id
:= Arg_Id
;
25351 -- Otherwise the type is non-Ghost. It is illegal to mix
25352 -- references to Ghost and non-Ghost entities
25355 elsif Present
(Ghost_Id
)
25356 and then not Ghost_Error_Posted
25358 Ghost_Error_Posted
:= True;
25360 Error_Msg_Name_1
:= Pname
;
25362 ("pragma % cannot mention ghost and non-ghost types",
25365 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
25366 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
25368 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
25369 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
25373 ("argument for pragma% must be type or subtype", Arg
);
25377 ("argument for pragma% must be type or subtype", Arg
);
25382 end Unreferenced_Objects
;
25384 ------------------------------
25385 -- Unreserve_All_Interrupts --
25386 ------------------------------
25388 -- pragma Unreserve_All_Interrupts;
25390 when Pragma_Unreserve_All_Interrupts
=>
25392 Check_Arg_Count
(0);
25394 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
25395 Unreserve_All_Interrupts
:= True;
25402 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
25404 when Pragma_Unsuppress
=>
25406 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
25412 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25414 when Pragma_Unused
=>
25415 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
25416 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
25418 -------------------
25419 -- Use_VADS_Size --
25420 -------------------
25422 -- pragma Use_VADS_Size;
25424 when Pragma_Use_VADS_Size
=>
25426 Check_Arg_Count
(0);
25427 Check_Valid_Configuration_Pragma
;
25428 Use_VADS_Size
:= True;
25430 ---------------------
25431 -- Validity_Checks --
25432 ---------------------
25434 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25436 when Pragma_Validity_Checks
=> Validity_Checks
: declare
25437 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25443 Check_Arg_Count
(1);
25444 Check_No_Identifiers
;
25446 -- Pragma always active unless in CodePeer or GNATprove modes,
25447 -- which use a fixed configuration of validity checks.
25449 if not (CodePeer_Mode
or GNATprove_Mode
) then
25450 if Nkind
(A
) = N_String_Literal
then
25454 Slen
: constant Natural := Natural (String_Length
(S
));
25455 Options
: String (1 .. Slen
);
25459 -- Couldn't we use a for loop here over Options'Range???
25463 C
:= Get_String_Char
(S
, Pos
(J
));
25465 -- This is a weird test, it skips setting validity
25466 -- checks entirely if any element of S is out of
25467 -- range of Character, what is that about ???
25469 exit when not In_Character_Range
(C
);
25470 Options
(J
) := Get_Character
(C
);
25473 Set_Validity_Check_Options
(Options
);
25481 elsif Nkind
(A
) = N_Identifier
then
25482 if Chars
(A
) = Name_All_Checks
then
25483 Set_Validity_Check_Options
("a");
25484 elsif Chars
(A
) = Name_On
then
25485 Validity_Checks_On
:= True;
25486 elsif Chars
(A
) = Name_Off
then
25487 Validity_Checks_On
:= False;
25491 end Validity_Checks
;
25497 -- pragma Volatile (LOCAL_NAME);
25499 when Pragma_Volatile
=>
25500 Process_Atomic_Independent_Shared_Volatile
;
25502 -------------------------
25503 -- Volatile_Components --
25504 -------------------------
25506 -- pragma Volatile_Components (array_LOCAL_NAME);
25508 -- Volatile is handled by the same circuit as Atomic_Components
25510 --------------------------
25511 -- Volatile_Full_Access --
25512 --------------------------
25514 -- pragma Volatile_Full_Access (LOCAL_NAME);
25516 when Pragma_Volatile_Full_Access
=>
25518 Process_Atomic_Independent_Shared_Volatile
;
25520 -----------------------
25521 -- Volatile_Function --
25522 -----------------------
25524 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25526 when Pragma_Volatile_Function
=> Volatile_Function
: declare
25527 Over_Id
: Entity_Id
;
25528 Spec_Id
: Entity_Id
;
25529 Subp_Decl
: Node_Id
;
25533 Check_No_Identifiers
;
25534 Check_At_Most_N_Arguments
(1);
25537 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25539 -- Generic subprogram
25541 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25544 -- Body acts as spec
25546 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25547 and then No
(Corresponding_Spec
(Subp_Decl
))
25551 -- Body stub acts as spec
25553 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25554 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25560 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25568 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25570 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
25575 -- A pragma that applies to a Ghost entity becomes Ghost for the
25576 -- purposes of legality checks and removal of ignored Ghost code.
25578 Mark_Ghost_Pragma
(N
, Spec_Id
);
25580 -- Chain the pragma on the contract for completeness
25582 Add_Contract_Item
(N
, Spec_Id
);
25584 -- The legality checks of pragma Volatile_Function are affected by
25585 -- the SPARK mode in effect. Analyze all pragmas in a specific
25588 Analyze_If_Present
(Pragma_SPARK_Mode
);
25590 -- A volatile function cannot override a non-volatile function
25591 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25592 -- in New_Overloaded_Entity, however at that point the pragma has
25593 -- not been processed yet.
25595 Over_Id
:= Overridden_Operation
(Spec_Id
);
25597 if Present
(Over_Id
)
25598 and then not Is_Volatile_Function
(Over_Id
)
25601 ("incompatible volatile function values in effect", Spec_Id
);
25603 Error_Msg_Sloc
:= Sloc
(Over_Id
);
25605 ("\& declared # with Volatile_Function value False",
25608 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
25610 ("\overridden # with Volatile_Function value True",
25614 -- Analyze the Boolean expression (if any)
25616 if Present
(Arg1
) then
25617 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
25619 end Volatile_Function
;
25621 ----------------------
25622 -- Warning_As_Error --
25623 ----------------------
25625 -- pragma Warning_As_Error (static_string_EXPRESSION);
25627 when Pragma_Warning_As_Error
=>
25629 Check_Arg_Count
(1);
25630 Check_No_Identifiers
;
25631 Check_Valid_Configuration_Pragma
;
25633 if not Is_Static_String_Expression
(Arg1
) then
25635 ("argument of pragma% must be static string expression",
25638 -- OK static string expression
25641 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
25642 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
25643 new String'(Acquire_Warning_Match_String
25644 (Expr_Value_S (Get_Pragma_Arg (Arg1))));
25651 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25653 -- DETAILS ::= On | Off
25654 -- DETAILS ::= On | Off, local_NAME
25655 -- DETAILS ::= static_string_EXPRESSION
25656 -- DETAILS ::= On | Off, static_string_EXPRESSION
25658 -- TOOL_NAME ::= GNAT | GNATprove
25660 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25662 -- Note: If the first argument matches an allowed tool name, it is
25663 -- always considered to be a tool name, even if there is a string
25664 -- variable of that name.
25666 -- Note if the second argument of DETAILS is a local_NAME then the
25667 -- second form is always understood. If the intention is to use
25668 -- the fourth form, then you can write NAME & "" to force the
25669 -- intepretation as a static_string_EXPRESSION.
25671 when Pragma_Warnings => Warnings : declare
25672 Reason : String_Id;
25676 Check_At_Least_N_Arguments (1);
25678 -- See if last argument is labeled Reason. If so, make sure we
25679 -- have a string literal or a concatenation of string literals,
25680 -- and acquire the REASON string. Then remove the REASON argument
25681 -- by decreasing Num_Args by one; Remaining processing looks only
25682 -- at first Num_Args arguments).
25685 Last_Arg : constant Node_Id :=
25686 Last (Pragma_Argument_Associations (N));
25689 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25690 and then Chars (Last_Arg) = Name_Reason
25693 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25694 Reason := End_String;
25695 Arg_Count := Arg_Count - 1;
25697 -- Not allowed in compiler units (bootstrap issues)
25699 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25701 -- No REASON string, set null string as reason
25704 Reason := Null_String_Id;
25708 -- Now proceed with REASON taken care of and eliminated
25710 Check_No_Identifiers;
25712 -- If debug flag -gnatd.i is set, pragma is ignored
25714 if Debug_Flag_Dot_I then
25718 -- Process various forms of the pragma
25721 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25722 Shifted_Args : List_Id;
25725 -- See if first argument is a tool name, currently either
25726 -- GNAT or GNATprove. If so, either ignore the pragma if the
25727 -- tool used does not match, or continue as if no tool name
25728 -- was given otherwise, by shifting the arguments.
25730 if Nkind (Argx) = N_Identifier
25731 and then Chars (Argx) in Name_Gnat | Name_Gnatprove
25733 if Chars (Argx) = Name_Gnat then
25734 if CodePeer_Mode or GNATprove_Mode then
25735 Rewrite (N, Make_Null_Statement (Loc));
25740 elsif Chars (Argx) = Name_Gnatprove then
25741 if not GNATprove_Mode then
25742 Rewrite (N, Make_Null_Statement (Loc));
25748 raise Program_Error;
25751 -- At this point, the pragma Warnings applies to the tool,
25752 -- so continue with shifted arguments.
25754 Arg_Count := Arg_Count - 1;
25756 if Arg_Count = 1 then
25757 Shifted_Args := New_List (New_Copy (Arg2));
25758 elsif Arg_Count = 2 then
25759 Shifted_Args := New_List (New_Copy (Arg2),
25761 elsif Arg_Count = 3 then
25762 Shifted_Args := New_List (New_Copy (Arg2),
25766 raise Program_Error;
25771 Chars => Name_Warnings,
25772 Pragma_Argument_Associations => Shifted_Args));
25777 -- One argument case
25779 if Arg_Count = 1 then
25781 -- On/Off one argument case was processed by parser
25783 if Nkind (Argx) = N_Identifier
25784 and then Chars (Argx) in Name_On | Name_Off
25788 -- One argument case must be ON/OFF or static string expr
25790 elsif not Is_Static_String_Expression (Arg1) then
25792 ("argument of pragma% must be On/Off or static string "
25793 & "expression", Arg1);
25795 -- One argument string expression case
25799 Lit : constant Node_Id := Expr_Value_S (Argx);
25800 Str : constant String_Id := Strval (Lit);
25801 Len : constant Nat := String_Length (Str);
25809 while J <= Len loop
25810 C := Get_String_Char (Str, J);
25811 OK := In_Character_Range (C);
25814 Chr := Get_Character (C);
25816 -- Dash case: only -Wxxx is accepted
25823 C := Get_String_Char (Str, J);
25824 Chr := Get_Character (C);
25825 exit when Chr = 'W
';
25830 elsif J < Len and then Chr = '.' then
25832 C := Get_String_Char (Str, J);
25833 Chr := Get_Character (C);
25835 if not Set_Dot_Warning_Switch (Chr) then
25837 ("invalid warning switch character "
25838 & '.' & Chr, Arg1);
25844 OK := Set_Warning_Switch (Chr);
25849 ("invalid warning switch character " & Chr,
25855 ("invalid wide character in warning switch ",
25864 -- Two or more arguments (must be two)
25867 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25868 Check_Arg_Count (2);
25876 E_Id := Get_Pragma_Arg (Arg2);
25879 -- In the expansion of an inlined body, a reference to
25880 -- the formal may be wrapped in a conversion if the
25881 -- actual is a conversion. Retrieve the real entity name.
25883 if (In_Instance_Body or In_Inlined_Body)
25884 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25886 E_Id := Expression (E_Id);
25889 -- Entity name case
25891 if Is_Entity_Name (E_Id) then
25892 E := Entity (E_Id);
25899 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25902 -- Suppress elaboration warnings if the entity
25903 -- denotes an elaboration target.
25905 if Is_Elaboration_Target (E) then
25906 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25909 -- For OFF case, make entry in warnings off
25910 -- pragma table for later processing. But we do
25911 -- not do that within an instance, since these
25912 -- warnings are about what is needed in the
25913 -- template, not an instance of it.
25915 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25916 and then Warn_On_Warnings_Off
25917 and then not In_Instance
25919 Warnings_Off_Pragmas.Append ((N, E, Reason));
25922 if Is_Enumeration_Type (E) then
25926 Lit := First_Literal (E);
25927 while Present (Lit) loop
25928 Set_Warnings_Off (Lit);
25929 Next_Literal (Lit);
25934 exit when No (Homonym (E));
25939 -- Error if not entity or static string expression case
25941 elsif not Is_Static_String_Expression (Arg2) then
25943 ("second argument of pragma% must be entity name "
25944 & "or static string expression", Arg2);
25946 -- Static string expression case
25949 -- Note on configuration pragma case: If this is a
25950 -- configuration pragma, then for an OFF pragma, we
25951 -- just set Config True in the call, which is all
25952 -- that needs to be done. For the case of ON, this
25953 -- is normally an error, unless it is canceling the
25954 -- effect of a previous OFF pragma in the same file.
25955 -- In any other case, an error will be signalled (ON
25956 -- with no matching OFF).
25958 -- Note: We set Used if we are inside a generic to
25959 -- disable the test that the non-config case actually
25960 -- cancels a warning. That's because we can't be sure
25961 -- there isn't an instantiation in some other unit
25962 -- where a warning is suppressed.
25964 -- We could do a little better here by checking if the
25965 -- generic unit we are inside is public, but for now
25966 -- we don't bother with that refinement.
25969 Message : constant String :=
25970 Acquire_Warning_Match_String
25971 (Expr_Value_S (Get_Pragma_Arg (Arg2)));
25973 if Chars (Argx) = Name_Off then
25974 Set_Specific_Warning_Off
25975 (Loc, Message, Reason,
25976 Config => Is_Configuration_Pragma,
25977 Used => Inside_A_Generic or else In_Instance);
25979 elsif Chars (Argx) = Name_On then
25980 Set_Specific_Warning_On (Loc, Message, Err);
25984 ("??pragma Warnings On with no matching "
25985 & "Warnings Off", N);
25995 -------------------
25996 -- Weak_External --
25997 -------------------
25999 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
26001 when Pragma_Weak_External => Weak_External : declare
26006 Check_Arg_Count (1);
26007 Check_Optional_Identifier (Arg1, Name_Entity);
26008 Check_Arg_Is_Library_Level_Local_Name (Arg1);
26009 Ent := Entity (Get_Pragma_Arg (Arg1));
26011 if Rep_Item_Too_Early (Ent, N) then
26014 Ent := Underlying_Type (Ent);
26017 -- The pragma applies to entities with addresses
26019 if Is_Type (Ent) then
26020 Error_Pragma ("pragma applies to objects and subprograms");
26023 -- The only processing required is to link this item on to the
26024 -- list of rep items for the given entity. This is accomplished
26025 -- by the call to Rep_Item_Too_Late (when no error is detected
26026 -- and False is returned).
26028 if Rep_Item_Too_Late (Ent, N) then
26031 Set_Has_Gigi_Rep_Item (Ent);
26035 -----------------------------
26036 -- Wide_Character_Encoding --
26037 -----------------------------
26039 -- pragma Wide_Character_Encoding (IDENTIFIER);
26041 when Pragma_Wide_Character_Encoding =>
26044 -- Nothing to do, handled in parser. Note that we do not enforce
26045 -- configuration pragma placement, this pragma can appear at any
26046 -- place in the source, allowing mixed encodings within a single
26051 --------------------
26052 -- Unknown_Pragma --
26053 --------------------
26055 -- Should be impossible, since the case of an unknown pragma is
26056 -- separately processed before the case statement is entered.
26058 when Unknown_Pragma =>
26059 raise Program_Error;
26062 -- AI05-0144: detect dangerous order dependence. Disabled for now,
26063 -- until AI is formally approved.
26065 -- Check_Order_Dependence;
26068 when Pragma_Exit => null;
26069 end Analyze_Pragma;
26071 ---------------------------------------------
26072 -- Analyze_Pre_Post_Condition_In_Decl_Part --
26073 ---------------------------------------------
26075 -- WARNING: This routine manages Ghost regions. Return statements must be
26076 -- replaced by gotos which jump to the end of the routine and restore the
26079 procedure Analyze_Pre_Post_Condition_In_Decl_Part
26081 Freeze_Id : Entity_Id := Empty)
26083 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
26084 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
26086 Disp_Typ : Entity_Id;
26087 -- The dispatching type of the subprogram subject to the pre- or
26090 function Check_References (Nod : Node_Id) return Traverse_Result;
26091 -- Check that expression Nod does not mention non-primitives of the
26092 -- type, global objects of the type, or other illegalities described
26093 -- and implied by AI12-0113.
26095 ----------------------
26096 -- Check_References --
26097 ----------------------
26099 function Check_References (Nod : Node_Id) return Traverse_Result is
26101 if Nkind (Nod) = N_Function_Call
26102 and then Is_Entity_Name (Name (Nod))
26105 Func : constant Entity_Id := Entity (Name (Nod));
26109 -- An operation of the type must be a primitive
26111 if No (Find_Dispatching_Type (Func)) then
26112 Form := First_Formal (Func);
26113 while Present (Form) loop
26114 if Etype (Form) = Disp_Typ then
26116 ("operation in class-wide condition must be "
26117 & "primitive of &", Nod, Disp_Typ);
26120 Next_Formal (Form);
26123 -- A return object of the type is illegal as well
26125 if Etype (Func) = Disp_Typ
26126 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
26129 ("operation in class-wide condition must be primitive "
26130 & "of &", Nod, Disp_Typ);
26135 elsif Is_Entity_Name (Nod)
26137 (Etype (Nod) = Disp_Typ
26138 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26139 and then Ekind (Entity (Nod)) in E_Constant | E_Variable
26142 ("object in class-wide condition must be formal of type &",
26145 elsif Nkind (Nod) = N_Explicit_Dereference
26146 and then (Etype (Nod) = Disp_Typ
26147 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
26148 and then (not Is_Entity_Name (Prefix (Nod))
26149 or else not Is_Formal (Entity (Prefix (Nod))))
26152 ("operation in class-wide condition must be primitive of &",
26157 end Check_References;
26159 procedure Check_Class_Wide_Condition is
26160 new Traverse_Proc (Check_References);
26164 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
26166 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
26167 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
26168 -- Save the Ghost-related attributes to restore on exit
26171 Restore_Scope : Boolean := False;
26173 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
26176 -- Do not analyze the pragma multiple times
26178 if Is_Analyzed_Pragma (N) then
26182 -- Set the Ghost mode in effect from the pragma. Due to the delayed
26183 -- analysis of the pragma, the Ghost mode at point of declaration and
26184 -- point of analysis may not necessarily be the same. Use the mode in
26185 -- effect at the point of declaration.
26187 Set_Ghost_Mode (N);
26189 -- Ensure that the subprogram and its formals are visible when analyzing
26190 -- the expression of the pragma.
26192 if not In_Open_Scopes (Spec_Id) then
26193 Restore_Scope := True;
26194 Push_Scope (Spec_Id);
26196 if Is_Generic_Subprogram (Spec_Id) then
26197 Install_Generic_Formals (Spec_Id);
26199 Install_Formals (Spec_Id);
26203 Errors := Serious_Errors_Detected;
26204 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
26206 -- Emit a clarification message when the expression contains at least
26207 -- one undefined reference, possibly due to contract freezing.
26209 if Errors /= Serious_Errors_Detected
26210 and then Present (Freeze_Id)
26211 and then Has_Undefined_Reference (Expr)
26213 Contract_Freeze_Error (Spec_Id, Freeze_Id);
26216 if Class_Present (N) then
26218 -- Verify that a class-wide condition is legal, i.e. the operation is
26219 -- a primitive of a tagged type. Note that a generic subprogram is
26220 -- not a primitive operation.
26222 Disp_Typ := Find_Dispatching_Type (Spec_Id);
26224 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
26225 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
26227 if From_Aspect_Specification (N) then
26229 ("aspect % can only be specified for a primitive operation "
26230 & "of a tagged type", Corresponding_Aspect (N));
26232 -- The pragma is a source construct
26236 ("pragma % can only be specified for a primitive operation "
26237 & "of a tagged type", N);
26240 -- Remaining semantic checks require a full tree traversal
26243 Check_Class_Wide_Condition (Expr);
26248 if Restore_Scope then
26252 -- Currently it is not possible to inline pre/postconditions on a
26253 -- subprogram subject to pragma Inline_Always.
26255 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
26256 Set_Is_Analyzed_Pragma (N);
26258 Restore_Ghost_Region (Saved_GM, Saved_IGR);
26259 end Analyze_Pre_Post_Condition_In_Decl_Part;
26261 ------------------------------------------
26262 -- Analyze_Refined_Depends_In_Decl_Part --
26263 ------------------------------------------
26265 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
26266 procedure Check_Dependency_Clause
26267 (Spec_Id : Entity_Id;
26268 Dep_Clause : Node_Id;
26269 Dep_States : Elist_Id;
26270 Refinements : List_Id;
26271 Matched_Items : in out Elist_Id);
26272 -- Try to match a single dependency clause Dep_Clause against one or
26273 -- more refinement clauses found in list Refinements. Each successful
26274 -- match eliminates at least one refinement clause from Refinements.
26275 -- Spec_Id denotes the entity of the related subprogram. Dep_States
26276 -- denotes the entities of all abstract states which appear in pragma
26277 -- Depends. Matched_Items contains the entities of all successfully
26278 -- matched items found in pragma Depends.
26280 procedure Check_Output_States
26281 (Spec_Inputs : Elist_Id;
26282 Spec_Outputs : Elist_Id;
26283 Body_Inputs : Elist_Id;
26284 Body_Outputs : Elist_Id);
26285 -- Determine whether pragma Depends contains an output state with a
26286 -- visible refinement and if so, ensure that pragma Refined_Depends
26287 -- mentions all its constituents as outputs. Spec_Inputs and
26288 -- Spec_Outputs denote the inputs and outputs of the subprogram spec
26289 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote
26290 -- the inputs and outputs of the subprogram body synthesized from pragma
26291 -- Refined_Depends.
26293 function Collect_States (Clauses : List_Id) return Elist_Id;
26294 -- Given a normalized list of dependencies obtained from calling
26295 -- Normalize_Clauses, return a list containing the entities of all
26296 -- states appearing in dependencies. It helps in checking refinements
26297 -- involving a state and a corresponding constituent which is not a
26298 -- direct constituent of the state.
26300 procedure Normalize_Clauses (Clauses : List_Id);
26301 -- Given a list of dependence or refinement clauses Clauses, normalize
26302 -- each clause by creating multiple dependencies with exactly one input
26305 procedure Remove_Extra_Clauses
26306 (Clauses : List_Id;
26307 Matched_Items : Elist_Id);
26308 -- Given a list of refinement clauses Clauses, remove all clauses whose
26309 -- inputs and/or outputs have been previously matched. See the body for
26310 -- all special cases. Matched_Items contains the entities of all matched
26311 -- items found in pragma Depends.
26313 procedure Report_Extra_Clauses (Clauses : List_Id);
26314 -- Emit an error for each extra clause found in list Clauses
26316 -----------------------------
26317 -- Check_Dependency_Clause --
26318 -----------------------------
26320 procedure Check_Dependency_Clause
26321 (Spec_Id : Entity_Id;
26322 Dep_Clause : Node_Id;
26323 Dep_States : Elist_Id;
26324 Refinements : List_Id;
26325 Matched_Items : in out Elist_Id)
26327 Dep_Input : constant Node_Id := Expression (Dep_Clause);
26328 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
26330 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
26331 -- Determine whether dependency item Dep_Item has been matched in a
26332 -- previous clause.
26334 function Is_In_Out_State_Clause return Boolean;
26335 -- Determine whether dependence clause Dep_Clause denotes an abstract
26336 -- state that depends on itself (State => State).
26338 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
26339 -- Determine whether item Item denotes an abstract state with visible
26340 -- null refinement.
26342 procedure Match_Items
26343 (Dep_Item : Node_Id;
26344 Ref_Item : Node_Id;
26345 Matched : out Boolean);
26346 -- Try to match dependence item Dep_Item against refinement item
26347 -- Ref_Item. To match against a possible null refinement (see 2, 9),
26348 -- set Ref_Item to Empty. Flag Matched is set to True when one of
26349 -- the following conformance scenarios is in effect:
26350 -- 1) Both items denote null
26351 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
26352 -- 3) Both items denote attribute 'Result
26353 -- 4) Both items denote the same object
26354 -- 5) Both items denote the same formal parameter
26355 -- 6) Both items denote the same current instance of a type
26356 -- 7) Both items denote the same discriminant
26357 -- 8) Dep_Item is an abstract state with visible null refinement
26358 -- and Ref_Item denotes null.
26359 -- 9) Dep_Item is an abstract state with visible null refinement
26360 -- and Ref_Item is Empty (special case).
26361 -- 10) Dep_Item is an abstract state with full or partial visible
26362 -- non-null refinement and Ref_Item denotes one of its
26364 -- 11) Dep_Item is an abstract state without a full visible
26365 -- refinement and Ref_Item denotes the same state.
26366 -- When scenario 10 is in effect, the entity of the abstract state
26367 -- denoted by Dep_Item is added to list Refined_States.
26369 procedure Record_Item
(Item_Id
: Entity_Id
);
26370 -- Store the entity of an item denoted by Item_Id in Matched_Items
26372 ------------------------
26373 -- Is_Already_Matched --
26374 ------------------------
26376 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
26377 Item_Id
: Entity_Id
:= Empty
;
26380 -- When the dependency item denotes attribute 'Result, check for
26381 -- the entity of the related subprogram.
26383 if Is_Attribute_Result
(Dep_Item
) then
26384 Item_Id
:= Spec_Id
;
26386 elsif Is_Entity_Name
(Dep_Item
) then
26387 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26391 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
26392 end Is_Already_Matched
;
26394 ----------------------------
26395 -- Is_In_Out_State_Clause --
26396 ----------------------------
26398 function Is_In_Out_State_Clause
return Boolean is
26399 Dep_Input_Id
: Entity_Id
;
26400 Dep_Output_Id
: Entity_Id
;
26403 -- Detect the following clause:
26406 if Is_Entity_Name
(Dep_Input
)
26407 and then Is_Entity_Name
(Dep_Output
)
26409 -- Handle abstract views generated for limited with clauses
26411 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
26412 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
26415 Ekind
(Dep_Input_Id
) = E_Abstract_State
26416 and then Dep_Input_Id
= Dep_Output_Id
;
26420 end Is_In_Out_State_Clause
;
26422 ---------------------------
26423 -- Is_Null_Refined_State --
26424 ---------------------------
26426 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
26427 Item_Id
: Entity_Id
;
26430 if Is_Entity_Name
(Item
) then
26432 -- Handle abstract views generated for limited with clauses
26434 Item_Id
:= Available_View
(Entity_Of
(Item
));
26437 Ekind
(Item_Id
) = E_Abstract_State
26438 and then Has_Null_Visible_Refinement
(Item_Id
);
26442 end Is_Null_Refined_State
;
26448 procedure Match_Items
26449 (Dep_Item
: Node_Id
;
26450 Ref_Item
: Node_Id
;
26451 Matched
: out Boolean)
26453 Dep_Item_Id
: Entity_Id
;
26454 Ref_Item_Id
: Entity_Id
;
26457 -- Assume that the two items do not match
26461 -- A null matches null or Empty (special case)
26463 if Nkind
(Dep_Item
) = N_Null
26464 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26468 -- Attribute 'Result matches attribute 'Result
26470 elsif Is_Attribute_Result
(Dep_Item
)
26471 and then Is_Attribute_Result
(Ref_Item
)
26473 -- Put the entity of the related function on the list of
26474 -- matched items because attribute 'Result does not carry
26475 -- an entity similar to states and constituents.
26477 Record_Item
(Spec_Id
);
26480 -- Abstract states, current instances of concurrent types,
26481 -- discriminants, formal parameters and objects.
26483 elsif Is_Entity_Name
(Dep_Item
) then
26485 -- Handle abstract views generated for limited with clauses
26487 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26489 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
26491 -- An abstract state with visible null refinement matches
26492 -- null or Empty (special case).
26494 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
26495 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26497 Record_Item
(Dep_Item_Id
);
26500 -- An abstract state with visible non-null refinement
26501 -- matches one of its constituents, or itself for an
26502 -- abstract state with partial visible refinement.
26504 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
26505 if Is_Entity_Name
(Ref_Item
) then
26506 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
26508 if Ekind
(Ref_Item_Id
) in
26509 E_Abstract_State | E_Constant | E_Variable
26510 and then Present
(Encapsulating_State
(Ref_Item_Id
))
26511 and then Find_Encapsulating_State
26512 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
26514 Record_Item
(Dep_Item_Id
);
26517 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
26518 and then Ref_Item_Id
= Dep_Item_Id
26520 Record_Item
(Dep_Item_Id
);
26525 -- An abstract state without a visible refinement matches
26528 elsif Is_Entity_Name
(Ref_Item
)
26529 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26531 Record_Item
(Dep_Item_Id
);
26535 -- A current instance of a concurrent type, discriminant,
26536 -- formal parameter or an object matches itself.
26538 elsif Is_Entity_Name
(Ref_Item
)
26539 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26541 Record_Item
(Dep_Item_Id
);
26551 procedure Record_Item
(Item_Id
: Entity_Id
) is
26553 if No
(Matched_Items
) then
26554 Matched_Items
:= New_Elmt_List
;
26557 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
26562 Clause_Matched
: Boolean := False;
26563 Dummy
: Boolean := False;
26564 Inputs_Match
: Boolean;
26565 Next_Ref_Clause
: Node_Id
;
26566 Outputs_Match
: Boolean;
26567 Ref_Clause
: Node_Id
;
26568 Ref_Input
: Node_Id
;
26569 Ref_Output
: Node_Id
;
26571 -- Start of processing for Check_Dependency_Clause
26574 -- Do not perform this check in an instance because it was already
26575 -- performed successfully in the generic template.
26577 if In_Instance
then
26581 -- Examine all refinement clauses and compare them against the
26582 -- dependence clause.
26584 Ref_Clause
:= First
(Refinements
);
26585 while Present
(Ref_Clause
) loop
26586 Next_Ref_Clause
:= Next
(Ref_Clause
);
26588 -- Obtain the attributes of the current refinement clause
26590 Ref_Input
:= Expression
(Ref_Clause
);
26591 Ref_Output
:= First
(Choices
(Ref_Clause
));
26593 -- The current refinement clause matches the dependence clause
26594 -- when both outputs match and both inputs match. See routine
26595 -- Match_Items for all possible conformance scenarios.
26597 -- Depends Dep_Output => Dep_Input
26601 -- Refined_Depends Ref_Output => Ref_Input
26604 (Dep_Item
=> Dep_Input
,
26605 Ref_Item
=> Ref_Input
,
26606 Matched
=> Inputs_Match
);
26609 (Dep_Item
=> Dep_Output
,
26610 Ref_Item
=> Ref_Output
,
26611 Matched
=> Outputs_Match
);
26613 -- An In_Out state clause may be matched against a refinement with
26614 -- a null input or null output as long as the non-null side of the
26615 -- relation contains a valid constituent of the In_Out_State.
26617 if Is_In_Out_State_Clause
then
26619 -- Depends => (State => State)
26620 -- Refined_Depends => (null => Constit) -- OK
26623 and then not Outputs_Match
26624 and then Nkind
(Ref_Output
) = N_Null
26626 Outputs_Match
:= True;
26629 -- Depends => (State => State)
26630 -- Refined_Depends => (Constit => null) -- OK
26632 if not Inputs_Match
26633 and then Outputs_Match
26634 and then Nkind
(Ref_Input
) = N_Null
26636 Inputs_Match
:= True;
26640 -- The current refinement clause is legally constructed following
26641 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26642 -- the pool of candidates. The seach continues because a single
26643 -- dependence clause may have multiple matching refinements.
26645 if Inputs_Match
and Outputs_Match
then
26646 Clause_Matched
:= True;
26647 Remove
(Ref_Clause
);
26650 Ref_Clause
:= Next_Ref_Clause
;
26653 -- Depending on the order or composition of refinement clauses, an
26654 -- In_Out state clause may not be directly refinable.
26656 -- Refined_State => (State => (Constit_1, Constit_2))
26657 -- Depends => ((Output, State) => (Input, State))
26658 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26660 -- Matching normalized clause (State => State) fails because there is
26661 -- no direct refinement capable of satisfying this relation. Another
26662 -- similar case arises when clauses (Constit_1 => Input) and (Output
26663 -- => Constit_2) are matched first, leaving no candidates for clause
26664 -- (State => State). Both scenarios are legal as long as one of the
26665 -- previous clauses mentioned a valid constituent of State.
26667 if not Clause_Matched
26668 and then Is_In_Out_State_Clause
26669 and then Is_Already_Matched
(Dep_Input
)
26671 Clause_Matched
:= True;
26674 -- A clause where the input is an abstract state with visible null
26675 -- refinement or a 'Result attribute is implicitly matched when the
26676 -- output has already been matched in a previous clause.
26678 -- Refined_State => (State => null)
26679 -- Depends => (Output => State) -- implicitly OK
26680 -- Refined_Depends => (Output => ...)
26681 -- Depends => (...'Result => State) -- implicitly OK
26682 -- Refined_Depends => (...'Result => ...)
26684 if not Clause_Matched
26685 and then Is_Null_Refined_State
(Dep_Input
)
26686 and then Is_Already_Matched
(Dep_Output
)
26688 Clause_Matched
:= True;
26691 -- A clause where the output is an abstract state with visible null
26692 -- refinement is implicitly matched when the input has already been
26693 -- matched in a previous clause.
26695 -- Refined_State => (State => null)
26696 -- Depends => (State => Input) -- implicitly OK
26697 -- Refined_Depends => (... => Input)
26699 if not Clause_Matched
26700 and then Is_Null_Refined_State
(Dep_Output
)
26701 and then Is_Already_Matched
(Dep_Input
)
26703 Clause_Matched
:= True;
26706 -- At this point either all refinement clauses have been examined or
26707 -- pragma Refined_Depends contains a solitary null. Only an abstract
26708 -- state with null refinement can possibly match these cases.
26710 -- Refined_State => (State => null)
26711 -- Depends => (State => null)
26712 -- Refined_Depends => null -- OK
26714 if not Clause_Matched
then
26716 (Dep_Item
=> Dep_Input
,
26718 Matched
=> Inputs_Match
);
26721 (Dep_Item
=> Dep_Output
,
26723 Matched
=> Outputs_Match
);
26725 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
26728 -- If the contents of Refined_Depends are legal, then the current
26729 -- dependence clause should be satisfied either by an explicit match
26730 -- or by one of the special cases.
26732 if not Clause_Matched
then
26734 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
26735 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
26737 end Check_Dependency_Clause
;
26739 -------------------------
26740 -- Check_Output_States --
26741 -------------------------
26743 procedure Check_Output_States
26744 (Spec_Inputs
: Elist_Id
;
26745 Spec_Outputs
: Elist_Id
;
26746 Body_Inputs
: Elist_Id
;
26747 Body_Outputs
: Elist_Id
)
26749 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26750 -- Determine whether all constituents of state State_Id with full
26751 -- visible refinement are used as outputs in pragma Refined_Depends.
26752 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26754 -----------------------------
26755 -- Check_Constituent_Usage --
26756 -----------------------------
26758 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26759 Constits
: constant Elist_Id
:=
26760 Partial_Refinement_Constituents
(State_Id
);
26761 Constit_Elmt
: Elmt_Id
;
26762 Constit_Id
: Entity_Id
;
26763 Only_Partial
: constant Boolean :=
26764 not Has_Visible_Refinement
(State_Id
);
26765 Posted
: Boolean := False;
26768 if Present
(Constits
) then
26769 Constit_Elmt
:= First_Elmt
(Constits
);
26770 while Present
(Constit_Elmt
) loop
26771 Constit_Id
:= Node
(Constit_Elmt
);
26773 -- Issue an error when a constituent of State_Id is used,
26774 -- and State_Id has only partial visible refinement
26775 -- (SPARK RM 7.2.4(3d)).
26777 if Only_Partial
then
26778 if (Present
(Body_Inputs
)
26779 and then Appears_In
(Body_Inputs
, Constit_Id
))
26781 (Present
(Body_Outputs
)
26782 and then Appears_In
(Body_Outputs
, Constit_Id
))
26784 Error_Msg_Name_1
:= Chars
(State_Id
);
26786 ("constituent & of state % cannot be used in "
26787 & "dependence refinement", N
, Constit_Id
);
26788 Error_Msg_Name_1
:= Chars
(State_Id
);
26789 SPARK_Msg_N
("\use state % instead", N
);
26792 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26794 elsif Present
(Body_Inputs
)
26795 and then Appears_In
(Body_Inputs
, Constit_Id
)
26797 Error_Msg_Name_1
:= Chars
(State_Id
);
26799 ("constituent & of state % must act as output in "
26800 & "dependence refinement", N
, Constit_Id
);
26802 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26804 elsif No
(Body_Outputs
)
26805 or else not Appears_In
(Body_Outputs
, Constit_Id
)
26810 ("output state & must be replaced by all its "
26811 & "constituents in dependence refinement",
26816 ("\constituent & is missing in output list",
26820 Next_Elmt
(Constit_Elmt
);
26823 end Check_Constituent_Usage
;
26828 Item_Elmt
: Elmt_Id
;
26829 Item_Id
: Entity_Id
;
26831 -- Start of processing for Check_Output_States
26834 -- Do not perform this check in an instance because it was already
26835 -- performed successfully in the generic template.
26837 if In_Instance
then
26840 -- Inspect the outputs of pragma Depends looking for a state with a
26841 -- visible refinement.
26843 elsif Present
(Spec_Outputs
) then
26844 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
26845 while Present
(Item_Elmt
) loop
26846 Item
:= Node
(Item_Elmt
);
26848 -- Deal with the mixed nature of the input and output lists
26850 if Nkind
(Item
) = N_Defining_Identifier
then
26853 Item_Id
:= Available_View
(Entity_Of
(Item
));
26856 if Ekind
(Item_Id
) = E_Abstract_State
then
26858 -- The state acts as an input-output, skip it
26860 if Present
(Spec_Inputs
)
26861 and then Appears_In
(Spec_Inputs
, Item_Id
)
26865 -- Ensure that all of the constituents are utilized as
26866 -- outputs in pragma Refined_Depends.
26868 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26869 Check_Constituent_Usage
(Item_Id
);
26873 Next_Elmt
(Item_Elmt
);
26876 end Check_Output_States
;
26878 --------------------
26879 -- Collect_States --
26880 --------------------
26882 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
26883 procedure Collect_State
26885 States
: in out Elist_Id
);
26886 -- Add the entity of Item to list States when it denotes to a state
26888 -------------------
26889 -- Collect_State --
26890 -------------------
26892 procedure Collect_State
26894 States
: in out Elist_Id
)
26899 if Is_Entity_Name
(Item
) then
26900 Id
:= Entity_Of
(Item
);
26902 if Ekind
(Id
) = E_Abstract_State
then
26903 if No
(States
) then
26904 States
:= New_Elmt_List
;
26907 Append_Unique_Elmt
(Id
, States
);
26917 States
: Elist_Id
:= No_Elist
;
26919 -- Start of processing for Collect_States
26922 Clause
:= First
(Clauses
);
26923 while Present
(Clause
) loop
26924 Input
:= Expression
(Clause
);
26925 Output
:= First
(Choices
(Clause
));
26927 Collect_State
(Input
, States
);
26928 Collect_State
(Output
, States
);
26934 end Collect_States
;
26936 -----------------------
26937 -- Normalize_Clauses --
26938 -----------------------
26940 procedure Normalize_Clauses
(Clauses
: List_Id
) is
26941 procedure Normalize_Inputs
(Clause
: Node_Id
);
26942 -- Normalize clause Clause by creating multiple clauses for each
26943 -- input item of Clause. It is assumed that Clause has exactly one
26944 -- output. The transformation is as follows:
26946 -- Output => (Input_1, Input_2) -- original
26948 -- Output => Input_1 -- normalizations
26949 -- Output => Input_2
26951 procedure Normalize_Outputs
(Clause
: Node_Id
);
26952 -- Normalize clause Clause by creating multiple clause for each
26953 -- output item of Clause. The transformation is as follows:
26955 -- (Output_1, Output_2) => Input -- original
26957 -- Output_1 => Input -- normalization
26958 -- Output_2 => Input
26960 ----------------------
26961 -- Normalize_Inputs --
26962 ----------------------
26964 procedure Normalize_Inputs
(Clause
: Node_Id
) is
26965 Inputs
: constant Node_Id
:= Expression
(Clause
);
26966 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26967 Output
: constant List_Id
:= Choices
(Clause
);
26968 Last_Input
: Node_Id
;
26970 New_Clause
: Node_Id
;
26971 Next_Input
: Node_Id
;
26974 -- Normalization is performed only when the original clause has
26975 -- more than one input. Multiple inputs appear as an aggregate.
26977 if Nkind
(Inputs
) = N_Aggregate
then
26978 Last_Input
:= Last
(Expressions
(Inputs
));
26980 -- Create a new clause for each input
26982 Input
:= First
(Expressions
(Inputs
));
26983 while Present
(Input
) loop
26984 Next_Input
:= Next
(Input
);
26986 -- Unhook the current input from the original input list
26987 -- because it will be relocated to a new clause.
26991 -- Special processing for the last input. At this point the
26992 -- original aggregate has been stripped down to one element.
26993 -- Replace the aggregate by the element itself.
26995 if Input
= Last_Input
then
26996 Rewrite
(Inputs
, Input
);
26998 -- Generate a clause of the form:
27003 Make_Component_Association
(Loc
,
27004 Choices
=> New_Copy_List_Tree
(Output
),
27005 Expression
=> Input
);
27007 -- The new clause contains replicated content that has
27008 -- already been analyzed, mark the clause as analyzed.
27010 Set_Analyzed
(New_Clause
);
27011 Insert_After
(Clause
, New_Clause
);
27014 Input
:= Next_Input
;
27017 end Normalize_Inputs
;
27019 -----------------------
27020 -- Normalize_Outputs --
27021 -----------------------
27023 procedure Normalize_Outputs
(Clause
: Node_Id
) is
27024 Inputs
: constant Node_Id
:= Expression
(Clause
);
27025 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
27026 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
27027 Last_Output
: Node_Id
;
27028 New_Clause
: Node_Id
;
27029 Next_Output
: Node_Id
;
27033 -- Multiple outputs appear as an aggregate. Nothing to do when
27034 -- the clause has exactly one output.
27036 if Nkind
(Outputs
) = N_Aggregate
then
27037 Last_Output
:= Last
(Expressions
(Outputs
));
27039 -- Create a clause for each output. Note that each time a new
27040 -- clause is created, the original output list slowly shrinks
27041 -- until there is one item left.
27043 Output
:= First
(Expressions
(Outputs
));
27044 while Present
(Output
) loop
27045 Next_Output
:= Next
(Output
);
27047 -- Unhook the output from the original output list as it
27048 -- will be relocated to a new clause.
27052 -- Special processing for the last output. At this point
27053 -- the original aggregate has been stripped down to one
27054 -- element. Replace the aggregate by the element itself.
27056 if Output
= Last_Output
then
27057 Rewrite
(Outputs
, Output
);
27060 -- Generate a clause of the form:
27061 -- (Output => Inputs)
27064 Make_Component_Association
(Loc
,
27065 Choices
=> New_List
(Output
),
27066 Expression
=> New_Copy_Tree
(Inputs
));
27068 -- The new clause contains replicated content that has
27069 -- already been analyzed. There is not need to reanalyze
27072 Set_Analyzed
(New_Clause
);
27073 Insert_After
(Clause
, New_Clause
);
27076 Output
:= Next_Output
;
27079 end Normalize_Outputs
;
27085 -- Start of processing for Normalize_Clauses
27088 Clause
:= First
(Clauses
);
27089 while Present
(Clause
) loop
27090 Normalize_Outputs
(Clause
);
27094 Clause
:= First
(Clauses
);
27095 while Present
(Clause
) loop
27096 Normalize_Inputs
(Clause
);
27099 end Normalize_Clauses
;
27101 --------------------------
27102 -- Remove_Extra_Clauses --
27103 --------------------------
27105 procedure Remove_Extra_Clauses
27106 (Clauses
: List_Id
;
27107 Matched_Items
: Elist_Id
)
27111 Input_Id
: Entity_Id
;
27112 Next_Clause
: Node_Id
;
27114 State_Id
: Entity_Id
;
27117 Clause
:= First
(Clauses
);
27118 while Present
(Clause
) loop
27119 Next_Clause
:= Next
(Clause
);
27121 Input
:= Expression
(Clause
);
27122 Output
:= First
(Choices
(Clause
));
27124 -- Recognize a clause of the form
27128 -- where Input is a constituent of a state which was already
27129 -- successfully matched. This clause must be removed because it
27130 -- simply indicates that some of the constituents of the state
27133 -- Refined_State => (State => (Constit_1, Constit_2))
27134 -- Depends => (Output => State)
27135 -- Refined_Depends => ((Output => Constit_1), -- State matched
27136 -- (null => Constit_2)) -- OK
27138 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
27140 -- Handle abstract views generated for limited with clauses
27142 Input_Id
:= Available_View
(Entity_Of
(Input
));
27144 -- The input must be a constituent of a state
27146 if Ekind
(Input_Id
) in
27147 E_Abstract_State | E_Constant | E_Variable
27148 and then Present
(Encapsulating_State
(Input_Id
))
27150 State_Id
:= Encapsulating_State
(Input_Id
);
27152 -- The state must have a non-null visible refinement and be
27153 -- matched in a previous clause.
27155 if Has_Non_Null_Visible_Refinement
(State_Id
)
27156 and then Contains
(Matched_Items
, State_Id
)
27162 -- Recognize a clause of the form
27166 -- where Output is an arbitrary item. This clause must be removed
27167 -- because a null input legitimately matches anything.
27169 elsif Nkind
(Input
) = N_Null
then
27173 Clause
:= Next_Clause
;
27175 end Remove_Extra_Clauses
;
27177 --------------------------
27178 -- Report_Extra_Clauses --
27179 --------------------------
27181 procedure Report_Extra_Clauses
(Clauses
: List_Id
) is
27185 -- Do not perform this check in an instance because it was already
27186 -- performed successfully in the generic template.
27188 if In_Instance
then
27191 elsif Present
(Clauses
) then
27192 Clause
:= First
(Clauses
);
27193 while Present
(Clause
) loop
27195 ("unmatched or extra clause in dependence refinement",
27201 end Report_Extra_Clauses
;
27205 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27206 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27207 Errors
: constant Nat
:= Serious_Errors_Detected
;
27214 Body_Inputs
: Elist_Id
:= No_Elist
;
27215 Body_Outputs
: Elist_Id
:= No_Elist
;
27216 -- The inputs and outputs of the subprogram body synthesized from pragma
27217 -- Refined_Depends.
27219 Dependencies
: List_Id
:= No_List
;
27221 -- The corresponding Depends pragma along with its clauses
27223 Matched_Items
: Elist_Id
:= No_Elist
;
27224 -- A list containing the entities of all successfully matched items
27225 -- found in pragma Depends.
27227 Refinements
: List_Id
:= No_List
;
27228 -- The clauses of pragma Refined_Depends
27230 Spec_Id
: Entity_Id
;
27231 -- The entity of the subprogram subject to pragma Refined_Depends
27233 Spec_Inputs
: Elist_Id
:= No_Elist
;
27234 Spec_Outputs
: Elist_Id
:= No_Elist
;
27235 -- The inputs and outputs of the subprogram spec synthesized from pragma
27238 States
: Elist_Id
:= No_Elist
;
27239 -- A list containing the entities of all states whose constituents
27240 -- appear in pragma Depends.
27242 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
27245 -- Do not analyze the pragma multiple times
27247 if Is_Analyzed_Pragma
(N
) then
27251 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
27253 -- Use the anonymous object as the proper spec when Refined_Depends
27254 -- applies to the body of a single task type. The object carries the
27255 -- proper Chars as well as all non-refined versions of pragmas.
27257 if Is_Single_Concurrent_Type
(Spec_Id
) then
27258 Spec_Id
:= Anonymous_Object
(Spec_Id
);
27261 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27263 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
27264 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
27266 if No
(Depends
) then
27268 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
27269 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
27273 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27275 -- A null dependency relation renders the refinement useless because it
27276 -- cannot possibly mention abstract states with visible refinement. Note
27277 -- that the inverse is not true as states may be refined to null
27278 -- (SPARK RM 7.2.5(2)).
27280 if Nkind
(Deps
) = N_Null
then
27282 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
27283 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
27287 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
27288 -- This ensures that the categorization of all refined dependency items
27289 -- is consistent with their role.
27291 Analyze_Depends_In_Decl_Part
(N
);
27293 -- Do not match dependencies against refinements if Refined_Depends is
27294 -- illegal to avoid emitting misleading error.
27296 if Serious_Errors_Detected
= Errors
then
27298 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
27299 -- the inputs and outputs of the subprogram spec and body to verify
27300 -- the use of states with visible refinement and their constituents.
27302 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
27303 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
27305 Collect_Subprogram_Inputs_Outputs
27306 (Subp_Id
=> Spec_Id
,
27307 Synthesize
=> True,
27308 Subp_Inputs
=> Spec_Inputs
,
27309 Subp_Outputs
=> Spec_Outputs
,
27310 Global_Seen
=> Dummy
);
27312 Collect_Subprogram_Inputs_Outputs
27313 (Subp_Id
=> Body_Id
,
27314 Synthesize
=> True,
27315 Subp_Inputs
=> Body_Inputs
,
27316 Subp_Outputs
=> Body_Outputs
,
27317 Global_Seen
=> Dummy
);
27319 -- For an output state with a visible refinement, ensure that all
27320 -- constituents appear as outputs in the dependency refinement.
27322 Check_Output_States
27323 (Spec_Inputs
=> Spec_Inputs
,
27324 Spec_Outputs
=> Spec_Outputs
,
27325 Body_Inputs
=> Body_Inputs
,
27326 Body_Outputs
=> Body_Outputs
);
27329 -- Multiple dependency clauses appear as component associations of an
27330 -- aggregate. Note that the clauses are copied because the algorithm
27331 -- modifies them and this should not be visible in Depends.
27333 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
27334 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
27335 Normalize_Clauses
(Dependencies
);
27337 -- Gather all states which appear in Depends
27339 States
:= Collect_States
(Dependencies
);
27341 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
27343 if Nkind
(Refs
) = N_Null
then
27344 Refinements
:= No_List
;
27346 -- Multiple dependency clauses appear as component associations of an
27347 -- aggregate. Note that the clauses are copied because the algorithm
27348 -- modifies them and this should not be visible in Refined_Depends.
27350 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
27351 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
27352 Normalize_Clauses
(Refinements
);
27355 -- At this point the clauses of pragmas Depends and Refined_Depends
27356 -- have been normalized into simple dependencies between one output
27357 -- and one input. Examine all clauses of pragma Depends looking for
27358 -- matching clauses in pragma Refined_Depends.
27360 Clause
:= First
(Dependencies
);
27361 while Present
(Clause
) loop
27362 Check_Dependency_Clause
27363 (Spec_Id
=> Spec_Id
,
27364 Dep_Clause
=> Clause
,
27365 Dep_States
=> States
,
27366 Refinements
=> Refinements
,
27367 Matched_Items
=> Matched_Items
);
27372 -- Pragma Refined_Depends may contain multiple clarification clauses
27373 -- which indicate that certain constituents do not influence the data
27374 -- flow in any way. Such clauses must be removed as long as the state
27375 -- has been matched, otherwise they will be incorrectly flagged as
27378 -- Refined_State => (State => (Constit_1, Constit_2))
27379 -- Depends => (Output => State)
27380 -- Refined_Depends => ((Output => Constit_1), -- State matched
27381 -- (null => Constit_2)) -- must be removed
27383 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
27385 if Serious_Errors_Detected
= Errors
then
27386 Report_Extra_Clauses
(Refinements
);
27391 Set_Is_Analyzed_Pragma
(N
);
27392 end Analyze_Refined_Depends_In_Decl_Part
;
27394 -----------------------------------------
27395 -- Analyze_Refined_Global_In_Decl_Part --
27396 -----------------------------------------
27398 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
27400 -- The corresponding Global pragma
27402 Has_In_State
: Boolean := False;
27403 Has_In_Out_State
: Boolean := False;
27404 Has_Out_State
: Boolean := False;
27405 Has_Proof_In_State
: Boolean := False;
27406 -- These flags are set when the corresponding Global pragma has a state
27407 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27410 Has_Null_State
: Boolean := False;
27411 -- This flag is set when the corresponding Global pragma has at least
27412 -- one state with a null refinement.
27414 In_Constits
: Elist_Id
:= No_Elist
;
27415 In_Out_Constits
: Elist_Id
:= No_Elist
;
27416 Out_Constits
: Elist_Id
:= No_Elist
;
27417 Proof_In_Constits
: Elist_Id
:= No_Elist
;
27418 -- These lists contain the entities of all Input, In_Out, Output and
27419 -- Proof_In constituents that appear in Refined_Global and participate
27420 -- in state refinement.
27422 In_Items
: Elist_Id
:= No_Elist
;
27423 In_Out_Items
: Elist_Id
:= No_Elist
;
27424 Out_Items
: Elist_Id
:= No_Elist
;
27425 Proof_In_Items
: Elist_Id
:= No_Elist
;
27426 -- These lists contain the entities of all Input, In_Out, Output and
27427 -- Proof_In items defined in the corresponding Global pragma.
27429 Repeat_Items
: Elist_Id
:= No_Elist
;
27430 -- A list of all global items without full visible refinement found
27431 -- in pragma Global. These states should be repeated in the global
27432 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27433 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27435 Spec_Id
: Entity_Id
;
27436 -- The entity of the subprogram subject to pragma Refined_Global
27438 States
: Elist_Id
:= No_Elist
;
27439 -- A list of all states with full or partial visible refinement found in
27442 procedure Check_In_Out_States
;
27443 -- Determine whether the corresponding Global pragma mentions In_Out
27444 -- states with visible refinement and if so, ensure that one of the
27445 -- following completions apply to the constituents of the state:
27446 -- 1) there is at least one constituent of mode In_Out
27447 -- 2) there is at least one Input and one Output constituent
27448 -- 3) not all constituents are present and one of them is of mode
27450 -- This routine may remove elements from In_Constits, In_Out_Constits,
27451 -- Out_Constits and Proof_In_Constits.
27453 procedure Check_Input_States
;
27454 -- Determine whether the corresponding Global pragma mentions Input
27455 -- states with visible refinement and if so, ensure that at least one of
27456 -- its constituents appears as an Input item in Refined_Global.
27457 -- This routine may remove elements from In_Constits, In_Out_Constits,
27458 -- Out_Constits and Proof_In_Constits.
27460 procedure Check_Output_States
;
27461 -- Determine whether the corresponding Global pragma mentions Output
27462 -- states with visible refinement and if so, ensure that all of its
27463 -- constituents appear as Output items in Refined_Global.
27464 -- This routine may remove elements from In_Constits, In_Out_Constits,
27465 -- Out_Constits and Proof_In_Constits.
27467 procedure Check_Proof_In_States
;
27468 -- Determine whether the corresponding Global pragma mentions Proof_In
27469 -- states with visible refinement and if so, ensure that at least one of
27470 -- its constituents appears as a Proof_In item in Refined_Global.
27471 -- This routine may remove elements from In_Constits, In_Out_Constits,
27472 -- Out_Constits and Proof_In_Constits.
27474 procedure Check_Refined_Global_List
27476 Global_Mode
: Name_Id
:= Name_Input
);
27477 -- Verify the legality of a single global list declaration. Global_Mode
27478 -- denotes the current mode in effect.
27480 procedure Collect_Global_Items
27482 Mode
: Name_Id
:= Name_Input
);
27483 -- Gather all Input, In_Out, Output and Proof_In items from node List
27484 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27485 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27486 -- and Has_Proof_In_State are set when there is at least one abstract
27487 -- state with full or partial visible refinement available in the
27488 -- corresponding mode. Flag Has_Null_State is set when at least state
27489 -- has a null refinement. Mode denotes the current global mode in
27492 function Present_Then_Remove
27494 Item
: Entity_Id
) return Boolean;
27495 -- Search List for a particular entity Item. If Item has been found,
27496 -- remove it from List. This routine is used to strip lists In_Constits,
27497 -- In_Out_Constits and Out_Constits of valid constituents.
27499 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
27500 -- Same as function Present_Then_Remove, but do not report the presence
27501 -- of Item in List.
27503 procedure Report_Extra_Constituents
;
27504 -- Emit an error for each constituent found in lists In_Constits,
27505 -- In_Out_Constits and Out_Constits.
27507 procedure Report_Missing_Items
;
27508 -- Emit an error for each global item not repeated found in list
27511 -------------------------
27512 -- Check_In_Out_States --
27513 -------------------------
27515 procedure Check_In_Out_States
is
27516 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27517 -- Determine whether one of the following coverage scenarios is in
27519 -- 1) there is at least one constituent of mode In_Out or Output
27520 -- 2) there is at least one pair of constituents with modes Input
27521 -- and Output, or Proof_In and Output.
27522 -- 3) there is at least one constituent of mode Output and not all
27523 -- constituents are present.
27524 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27526 -----------------------------
27527 -- Check_Constituent_Usage --
27528 -----------------------------
27530 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27531 Constits
: constant Elist_Id
:=
27532 Partial_Refinement_Constituents
(State_Id
);
27533 Constit_Elmt
: Elmt_Id
;
27534 Constit_Id
: Entity_Id
;
27535 Has_Missing
: Boolean := False;
27536 In_Out_Seen
: Boolean := False;
27537 Input_Seen
: Boolean := False;
27538 Output_Seen
: Boolean := False;
27539 Proof_In_Seen
: Boolean := False;
27542 -- Process all the constituents of the state and note their modes
27543 -- within the global refinement.
27545 if Present
(Constits
) then
27546 Constit_Elmt
:= First_Elmt
(Constits
);
27547 while Present
(Constit_Elmt
) loop
27548 Constit_Id
:= Node
(Constit_Elmt
);
27550 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27551 Input_Seen
:= True;
27553 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
27554 In_Out_Seen
:= True;
27556 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27557 Output_Seen
:= True;
27559 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27561 Proof_In_Seen
:= True;
27564 Has_Missing
:= True;
27567 Next_Elmt
(Constit_Elmt
);
27571 -- An In_Out constituent is a valid completion
27573 if In_Out_Seen
then
27576 -- A pair of one Input/Proof_In and one Output constituent is a
27577 -- valid completion.
27579 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
27582 elsif Output_Seen
then
27584 -- A single Output constituent is a valid completion only when
27585 -- some of the other constituents are missing.
27587 if Has_Missing
then
27590 -- Otherwise all constituents are of mode Output
27594 ("global refinement of state & must include at least one "
27595 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27599 -- The state lacks a completion. When full refinement is visible,
27600 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27601 -- refinement is visible, emit an error if the abstract state
27602 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27603 -- both are utilized, Check_State_And_Constituent_Use. will issue
27606 elsif not Input_Seen
27607 and then not In_Out_Seen
27608 and then not Output_Seen
27609 and then not Proof_In_Seen
27611 if Has_Visible_Refinement
(State_Id
)
27612 or else Contains
(Repeat_Items
, State_Id
)
27615 ("missing global refinement of state &", N
, State_Id
);
27618 -- Otherwise the state has a malformed completion where at least
27619 -- one of the constituents has a different mode.
27623 ("global refinement of state & redefines the mode of its "
27624 & "constituents", N
, State_Id
);
27626 end Check_Constituent_Usage
;
27630 Item_Elmt
: Elmt_Id
;
27631 Item_Id
: Entity_Id
;
27633 -- Start of processing for Check_In_Out_States
27636 -- Do not perform this check in an instance because it was already
27637 -- performed successfully in the generic template.
27639 if In_Instance
then
27642 -- Inspect the In_Out items of the corresponding Global pragma
27643 -- looking for a state with a visible refinement.
27645 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
27646 Item_Elmt
:= First_Elmt
(In_Out_Items
);
27647 while Present
(Item_Elmt
) loop
27648 Item_Id
:= Node
(Item_Elmt
);
27650 -- Ensure that one of the three coverage variants is satisfied
27652 if Ekind
(Item_Id
) = E_Abstract_State
27653 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27655 Check_Constituent_Usage
(Item_Id
);
27658 Next_Elmt
(Item_Elmt
);
27661 end Check_In_Out_States
;
27663 ------------------------
27664 -- Check_Input_States --
27665 ------------------------
27667 procedure Check_Input_States
is
27668 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27669 -- Determine whether at least one constituent of state State_Id with
27670 -- full or partial visible refinement is used and has mode Input.
27671 -- Ensure that the remaining constituents do not have In_Out or
27672 -- Output modes. Emit an error if this is not the case
27673 -- (SPARK RM 7.2.4(5)).
27675 -----------------------------
27676 -- Check_Constituent_Usage --
27677 -----------------------------
27679 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27680 Constits
: constant Elist_Id
:=
27681 Partial_Refinement_Constituents
(State_Id
);
27682 Constit_Elmt
: Elmt_Id
;
27683 Constit_Id
: Entity_Id
;
27684 In_Seen
: Boolean := False;
27687 if Present
(Constits
) then
27688 Constit_Elmt
:= First_Elmt
(Constits
);
27689 while Present
(Constit_Elmt
) loop
27690 Constit_Id
:= Node
(Constit_Elmt
);
27692 -- At least one of the constituents appears as an Input
27694 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27697 -- A Proof_In constituent can refine an Input state as long
27698 -- as there is at least one Input constituent present.
27700 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27704 -- The constituent appears in the global refinement, but has
27705 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27707 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27708 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27710 Error_Msg_Name_1
:= Chars
(State_Id
);
27712 ("constituent & of state % must have mode `Input` in "
27713 & "global refinement", N
, Constit_Id
);
27716 Next_Elmt
(Constit_Elmt
);
27720 -- Not one of the constituents appeared as Input. Always emit an
27721 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27722 -- When only partial refinement is visible, emit an error if the
27723 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27724 -- the case where both are utilized, an error will be issued in
27725 -- Check_State_And_Constituent_Use.
27728 and then (Has_Visible_Refinement
(State_Id
)
27729 or else Contains
(Repeat_Items
, State_Id
))
27732 ("global refinement of state & must include at least one "
27733 & "constituent of mode `Input`", N
, State_Id
);
27735 end Check_Constituent_Usage
;
27739 Item_Elmt
: Elmt_Id
;
27740 Item_Id
: Entity_Id
;
27742 -- Start of processing for Check_Input_States
27745 -- Do not perform this check in an instance because it was already
27746 -- performed successfully in the generic template.
27748 if In_Instance
then
27751 -- Inspect the Input items of the corresponding Global pragma looking
27752 -- for a state with a visible refinement.
27754 elsif Has_In_State
and then Present
(In_Items
) then
27755 Item_Elmt
:= First_Elmt
(In_Items
);
27756 while Present
(Item_Elmt
) loop
27757 Item_Id
:= Node
(Item_Elmt
);
27759 -- When full refinement is visible, ensure that at least one of
27760 -- the constituents is utilized and is of mode Input. When only
27761 -- partial refinement is visible, ensure that either one of
27762 -- the constituents is utilized and is of mode Input, or the
27763 -- abstract state is repeated and no constituent is utilized.
27765 if Ekind
(Item_Id
) = E_Abstract_State
27766 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27768 Check_Constituent_Usage
(Item_Id
);
27771 Next_Elmt
(Item_Elmt
);
27774 end Check_Input_States
;
27776 -------------------------
27777 -- Check_Output_States --
27778 -------------------------
27780 procedure Check_Output_States
is
27781 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27782 -- Determine whether all constituents of state State_Id with full
27783 -- visible refinement are used and have mode Output. Emit an error
27784 -- if this is not the case (SPARK RM 7.2.4(5)).
27786 -----------------------------
27787 -- Check_Constituent_Usage --
27788 -----------------------------
27790 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27791 Constits
: constant Elist_Id
:=
27792 Partial_Refinement_Constituents
(State_Id
);
27793 Only_Partial
: constant Boolean :=
27794 not Has_Visible_Refinement
(State_Id
);
27795 Constit_Elmt
: Elmt_Id
;
27796 Constit_Id
: Entity_Id
;
27797 Posted
: Boolean := False;
27800 if Present
(Constits
) then
27801 Constit_Elmt
:= First_Elmt
(Constits
);
27802 while Present
(Constit_Elmt
) loop
27803 Constit_Id
:= Node
(Constit_Elmt
);
27805 -- Issue an error when a constituent of State_Id is utilized
27806 -- and State_Id has only partial visible refinement
27807 -- (SPARK RM 7.2.4(3d)).
27809 if Only_Partial
then
27810 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
27811 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
27813 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27815 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27817 Error_Msg_Name_1
:= Chars
(State_Id
);
27819 ("constituent & of state % cannot be used in global "
27820 & "refinement", N
, Constit_Id
);
27821 Error_Msg_Name_1
:= Chars
(State_Id
);
27822 SPARK_Msg_N
("\use state % instead", N
);
27825 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27828 -- The constituent appears in the global refinement, but has
27829 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27831 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27832 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27833 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27835 Error_Msg_Name_1
:= Chars
(State_Id
);
27837 ("constituent & of state % must have mode `Output` in "
27838 & "global refinement", N
, Constit_Id
);
27840 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27846 ("`Output` state & must be replaced by all its "
27847 & "constituents in global refinement", N
, State_Id
);
27851 ("\constituent & is missing in output list",
27855 Next_Elmt
(Constit_Elmt
);
27858 end Check_Constituent_Usage
;
27862 Item_Elmt
: Elmt_Id
;
27863 Item_Id
: Entity_Id
;
27865 -- Start of processing for Check_Output_States
27868 -- Do not perform this check in an instance because it was already
27869 -- performed successfully in the generic template.
27871 if In_Instance
then
27874 -- Inspect the Output items of the corresponding Global pragma
27875 -- looking for a state with a visible refinement.
27877 elsif Has_Out_State
and then Present
(Out_Items
) then
27878 Item_Elmt
:= First_Elmt
(Out_Items
);
27879 while Present
(Item_Elmt
) loop
27880 Item_Id
:= Node
(Item_Elmt
);
27882 -- When full refinement is visible, ensure that all of the
27883 -- constituents are utilized and they have mode Output. When
27884 -- only partial refinement is visible, ensure that no
27885 -- constituent is utilized.
27887 if Ekind
(Item_Id
) = E_Abstract_State
27888 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27890 Check_Constituent_Usage
(Item_Id
);
27893 Next_Elmt
(Item_Elmt
);
27896 end Check_Output_States
;
27898 ---------------------------
27899 -- Check_Proof_In_States --
27900 ---------------------------
27902 procedure Check_Proof_In_States
is
27903 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27904 -- Determine whether at least one constituent of state State_Id with
27905 -- full or partial visible refinement is used and has mode Proof_In.
27906 -- Ensure that the remaining constituents do not have Input, In_Out,
27907 -- or Output modes. Emit an error if this is not the case
27908 -- (SPARK RM 7.2.4(5)).
27910 -----------------------------
27911 -- Check_Constituent_Usage --
27912 -----------------------------
27914 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27915 Constits
: constant Elist_Id
:=
27916 Partial_Refinement_Constituents
(State_Id
);
27917 Constit_Elmt
: Elmt_Id
;
27918 Constit_Id
: Entity_Id
;
27919 Proof_In_Seen
: Boolean := False;
27922 if Present
(Constits
) then
27923 Constit_Elmt
:= First_Elmt
(Constits
);
27924 while Present
(Constit_Elmt
) loop
27925 Constit_Id
:= Node
(Constit_Elmt
);
27927 -- At least one of the constituents appears as Proof_In
27929 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
27930 Proof_In_Seen
:= True;
27932 -- The constituent appears in the global refinement, but has
27933 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27935 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27936 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27937 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27939 Error_Msg_Name_1
:= Chars
(State_Id
);
27941 ("constituent & of state % must have mode `Proof_In` "
27942 & "in global refinement", N
, Constit_Id
);
27945 Next_Elmt
(Constit_Elmt
);
27949 -- Not one of the constituents appeared as Proof_In. Always emit
27950 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27951 -- When only partial refinement is visible, emit an error if the
27952 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27953 -- the case where both are utilized, an error will be issued by
27954 -- Check_State_And_Constituent_Use.
27956 if not Proof_In_Seen
27957 and then (Has_Visible_Refinement
(State_Id
)
27958 or else Contains
(Repeat_Items
, State_Id
))
27961 ("global refinement of state & must include at least one "
27962 & "constituent of mode `Proof_In`", N
, State_Id
);
27964 end Check_Constituent_Usage
;
27968 Item_Elmt
: Elmt_Id
;
27969 Item_Id
: Entity_Id
;
27971 -- Start of processing for Check_Proof_In_States
27974 -- Do not perform this check in an instance because it was already
27975 -- performed successfully in the generic template.
27977 if In_Instance
then
27980 -- Inspect the Proof_In items of the corresponding Global pragma
27981 -- looking for a state with a visible refinement.
27983 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
27984 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
27985 while Present
(Item_Elmt
) loop
27986 Item_Id
:= Node
(Item_Elmt
);
27988 -- Ensure that at least one of the constituents is utilized
27989 -- and is of mode Proof_In. When only partial refinement is
27990 -- visible, ensure that either one of the constituents is
27991 -- utilized and is of mode Proof_In, or the abstract state
27992 -- is repeated and no constituent is utilized.
27994 if Ekind
(Item_Id
) = E_Abstract_State
27995 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27997 Check_Constituent_Usage
(Item_Id
);
28000 Next_Elmt
(Item_Elmt
);
28003 end Check_Proof_In_States
;
28005 -------------------------------
28006 -- Check_Refined_Global_List --
28007 -------------------------------
28009 procedure Check_Refined_Global_List
28011 Global_Mode
: Name_Id
:= Name_Input
)
28013 procedure Check_Refined_Global_Item
28015 Global_Mode
: Name_Id
);
28016 -- Verify the legality of a single global item declaration. Parameter
28017 -- Global_Mode denotes the current mode in effect.
28019 -------------------------------
28020 -- Check_Refined_Global_Item --
28021 -------------------------------
28023 procedure Check_Refined_Global_Item
28025 Global_Mode
: Name_Id
)
28027 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
28029 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
28030 -- Issue a common error message for all mode mismatches. Expect
28031 -- denotes the expected mode.
28033 -----------------------------
28034 -- Inconsistent_Mode_Error --
28035 -----------------------------
28037 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
28040 ("global item & has inconsistent modes", Item
, Item_Id
);
28042 Error_Msg_Name_1
:= Global_Mode
;
28043 Error_Msg_Name_2
:= Expect
;
28044 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
28045 end Inconsistent_Mode_Error
;
28049 Enc_State
: Entity_Id
:= Empty
;
28050 -- Encapsulating state for constituent, Empty otherwise
28052 -- Start of processing for Check_Refined_Global_Item
28055 if Ekind
(Item_Id
) in E_Abstract_State | E_Constant | E_Variable
28057 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
28060 -- When the state or object acts as a constituent of another
28061 -- state with a visible refinement, collect it for the state
28062 -- completeness checks performed later on. Note that the item
28063 -- acts as a constituent only when the encapsulating state is
28064 -- present in pragma Global.
28066 if Present
(Enc_State
)
28067 and then (Has_Visible_Refinement
(Enc_State
)
28068 or else Has_Partial_Visible_Refinement
(Enc_State
))
28069 and then Contains
(States
, Enc_State
)
28071 -- If the state has only partial visible refinement, remove it
28072 -- from the list of items that should be repeated from pragma
28075 if not Has_Visible_Refinement
(Enc_State
) then
28076 Present_Then_Remove
(Repeat_Items
, Enc_State
);
28079 if Global_Mode
= Name_Input
then
28080 Append_New_Elmt
(Item_Id
, In_Constits
);
28082 elsif Global_Mode
= Name_In_Out
then
28083 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
28085 elsif Global_Mode
= Name_Output
then
28086 Append_New_Elmt
(Item_Id
, Out_Constits
);
28088 elsif Global_Mode
= Name_Proof_In
then
28089 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
28092 -- When not a constituent, ensure that both occurrences of the
28093 -- item in pragmas Global and Refined_Global match. Also remove
28094 -- it when present from the list of items that should be repeated
28095 -- from pragma Global.
28098 Present_Then_Remove
(Repeat_Items
, Item_Id
);
28100 if Contains
(In_Items
, Item_Id
) then
28101 if Global_Mode
/= Name_Input
then
28102 Inconsistent_Mode_Error
(Name_Input
);
28105 elsif Contains
(In_Out_Items
, Item_Id
) then
28106 if Global_Mode
/= Name_In_Out
then
28107 Inconsistent_Mode_Error
(Name_In_Out
);
28110 elsif Contains
(Out_Items
, Item_Id
) then
28111 if Global_Mode
/= Name_Output
then
28112 Inconsistent_Mode_Error
(Name_Output
);
28115 elsif Contains
(Proof_In_Items
, Item_Id
) then
28118 -- The item does not appear in the corresponding Global pragma,
28119 -- it must be an extra (SPARK RM 7.2.4(3)).
28122 pragma Assert
(Present
(Global
));
28123 Error_Msg_Sloc
:= Sloc
(Global
);
28125 ("extra global item & does not refine or repeat any "
28126 & "global item #", Item
, Item_Id
);
28129 end Check_Refined_Global_Item
;
28135 -- Start of processing for Check_Refined_Global_List
28138 -- Do not perform this check in an instance because it was already
28139 -- performed successfully in the generic template.
28141 if In_Instance
then
28144 elsif Nkind
(List
) = N_Null
then
28147 -- Single global item declaration
28149 elsif Nkind
(List
) in N_Expanded_Name
28151 | N_Selected_Component
28153 Check_Refined_Global_Item
(List
, Global_Mode
);
28155 -- Simple global list or moded global list declaration
28157 elsif Nkind
(List
) = N_Aggregate
then
28159 -- The declaration of a simple global list appear as a collection
28162 if Present
(Expressions
(List
)) then
28163 Item
:= First
(Expressions
(List
));
28164 while Present
(Item
) loop
28165 Check_Refined_Global_Item
(Item
, Global_Mode
);
28169 -- The declaration of a moded global list appears as a collection
28170 -- of component associations where individual choices denote
28173 elsif Present
(Component_Associations
(List
)) then
28174 Item
:= First
(Component_Associations
(List
));
28175 while Present
(Item
) loop
28176 Check_Refined_Global_List
28177 (List
=> Expression
(Item
),
28178 Global_Mode
=> Chars
(First
(Choices
(Item
))));
28186 raise Program_Error
;
28192 raise Program_Error
;
28194 end Check_Refined_Global_List
;
28196 --------------------------
28197 -- Collect_Global_Items --
28198 --------------------------
28200 procedure Collect_Global_Items
28202 Mode
: Name_Id
:= Name_Input
)
28204 procedure Collect_Global_Item
28206 Item_Mode
: Name_Id
);
28207 -- Add a single item to the appropriate list. Item_Mode denotes the
28208 -- current mode in effect.
28210 -------------------------
28211 -- Collect_Global_Item --
28212 -------------------------
28214 procedure Collect_Global_Item
28216 Item_Mode
: Name_Id
)
28218 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
28219 -- The above handles abstract views of variables and states built
28220 -- for limited with clauses.
28223 -- Signal that the global list contains at least one abstract
28224 -- state with a visible refinement. Note that the refinement may
28225 -- be null in which case there are no constituents.
28227 if Ekind
(Item_Id
) = E_Abstract_State
then
28228 if Has_Null_Visible_Refinement
(Item_Id
) then
28229 Has_Null_State
:= True;
28231 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
28232 Append_New_Elmt
(Item_Id
, States
);
28234 if Item_Mode
= Name_Input
then
28235 Has_In_State
:= True;
28236 elsif Item_Mode
= Name_In_Out
then
28237 Has_In_Out_State
:= True;
28238 elsif Item_Mode
= Name_Output
then
28239 Has_Out_State
:= True;
28240 elsif Item_Mode
= Name_Proof_In
then
28241 Has_Proof_In_State
:= True;
28246 -- Record global items without full visible refinement found in
28247 -- pragma Global which should be repeated in the global refinement
28248 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
28250 if Ekind
(Item_Id
) /= E_Abstract_State
28251 or else not Has_Visible_Refinement
(Item_Id
)
28253 Append_New_Elmt
(Item_Id
, Repeat_Items
);
28256 -- Add the item to the proper list
28258 if Item_Mode
= Name_Input
then
28259 Append_New_Elmt
(Item_Id
, In_Items
);
28260 elsif Item_Mode
= Name_In_Out
then
28261 Append_New_Elmt
(Item_Id
, In_Out_Items
);
28262 elsif Item_Mode
= Name_Output
then
28263 Append_New_Elmt
(Item_Id
, Out_Items
);
28264 elsif Item_Mode
= Name_Proof_In
then
28265 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
28267 end Collect_Global_Item
;
28273 -- Start of processing for Collect_Global_Items
28276 if Nkind
(List
) = N_Null
then
28279 -- Single global item declaration
28281 elsif Nkind
(List
) in N_Expanded_Name
28283 | N_Selected_Component
28285 Collect_Global_Item
(List
, Mode
);
28287 -- Single global list or moded global list declaration
28289 elsif Nkind
(List
) = N_Aggregate
then
28291 -- The declaration of a simple global list appear as a collection
28294 if Present
(Expressions
(List
)) then
28295 Item
:= First
(Expressions
(List
));
28296 while Present
(Item
) loop
28297 Collect_Global_Item
(Item
, Mode
);
28301 -- The declaration of a moded global list appears as a collection
28302 -- of component associations where individual choices denote mode.
28304 elsif Present
(Component_Associations
(List
)) then
28305 Item
:= First
(Component_Associations
(List
));
28306 while Present
(Item
) loop
28307 Collect_Global_Items
28308 (List
=> Expression
(Item
),
28309 Mode
=> Chars
(First
(Choices
(Item
))));
28317 raise Program_Error
;
28320 -- To accommodate partial decoration of disabled SPARK features, this
28321 -- routine may be called with illegal input. If this is the case, do
28322 -- not raise Program_Error.
28327 end Collect_Global_Items
;
28329 -------------------------
28330 -- Present_Then_Remove --
28331 -------------------------
28333 function Present_Then_Remove
28335 Item
: Entity_Id
) return Boolean
28340 if Present
(List
) then
28341 Elmt
:= First_Elmt
(List
);
28342 while Present
(Elmt
) loop
28343 if Node
(Elmt
) = Item
then
28344 Remove_Elmt
(List
, Elmt
);
28353 end Present_Then_Remove
;
28355 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
28358 Ignore
:= Present_Then_Remove
(List
, Item
);
28359 end Present_Then_Remove
;
28361 -------------------------------
28362 -- Report_Extra_Constituents --
28363 -------------------------------
28365 procedure Report_Extra_Constituents
is
28366 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
28367 -- Emit an error for every element of List
28369 ---------------------------------------
28370 -- Report_Extra_Constituents_In_List --
28371 ---------------------------------------
28373 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
28374 Constit_Elmt
: Elmt_Id
;
28377 if Present
(List
) then
28378 Constit_Elmt
:= First_Elmt
(List
);
28379 while Present
(Constit_Elmt
) loop
28380 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
28381 Next_Elmt
(Constit_Elmt
);
28384 end Report_Extra_Constituents_In_List
;
28386 -- Start of processing for Report_Extra_Constituents
28389 -- Do not perform this check in an instance because it was already
28390 -- performed successfully in the generic template.
28392 if In_Instance
then
28396 Report_Extra_Constituents_In_List
(In_Constits
);
28397 Report_Extra_Constituents_In_List
(In_Out_Constits
);
28398 Report_Extra_Constituents_In_List
(Out_Constits
);
28399 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
28401 end Report_Extra_Constituents
;
28403 --------------------------
28404 -- Report_Missing_Items --
28405 --------------------------
28407 procedure Report_Missing_Items
is
28408 Item_Elmt
: Elmt_Id
;
28409 Item_Id
: Entity_Id
;
28412 -- Do not perform this check in an instance because it was already
28413 -- performed successfully in the generic template.
28415 if In_Instance
then
28419 if Present
(Repeat_Items
) then
28420 Item_Elmt
:= First_Elmt
(Repeat_Items
);
28421 while Present
(Item_Elmt
) loop
28422 Item_Id
:= Node
(Item_Elmt
);
28423 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
28424 Next_Elmt
(Item_Elmt
);
28428 end Report_Missing_Items
;
28432 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28433 Errors
: constant Nat
:= Serious_Errors_Detected
;
28435 No_Constit
: Boolean;
28437 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28440 -- Do not analyze the pragma multiple times
28442 if Is_Analyzed_Pragma
(N
) then
28446 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28448 -- Use the anonymous object as the proper spec when Refined_Global
28449 -- applies to the body of a single task type. The object carries the
28450 -- proper Chars as well as all non-refined versions of pragmas.
28452 if Is_Single_Concurrent_Type
(Spec_Id
) then
28453 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28456 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28457 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
28459 -- The subprogram declaration lacks pragma Global. This renders
28460 -- Refined_Global useless as there is nothing to refine.
28462 if No
(Global
) then
28464 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28465 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
28469 -- Extract all relevant items from the corresponding Global pragma
28471 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28473 -- Package and subprogram bodies are instantiated individually in
28474 -- a separate compiler pass. Due to this mode of instantiation, the
28475 -- refinement of a state may no longer be visible when a subprogram
28476 -- body contract is instantiated. Since the generic template is legal,
28477 -- do not perform this check in the instance to circumvent this oddity.
28479 if In_Instance
then
28482 -- Non-instance case
28485 -- The corresponding Global pragma must mention at least one
28486 -- state with a visible refinement at the point Refined_Global
28487 -- is processed. States with null refinements need Refined_Global
28488 -- pragma (SPARK RM 7.2.4(2)).
28490 if not Has_In_State
28491 and then not Has_In_Out_State
28492 and then not Has_Out_State
28493 and then not Has_Proof_In_State
28494 and then not Has_Null_State
28497 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28498 & "depend on abstract state with visible refinement"),
28502 -- The global refinement of inputs and outputs cannot be null when
28503 -- the corresponding Global pragma contains at least one item except
28504 -- in the case where we have states with null refinements.
28506 elsif Nkind
(Items
) = N_Null
28508 (Present
(In_Items
)
28509 or else Present
(In_Out_Items
)
28510 or else Present
(Out_Items
)
28511 or else Present
(Proof_In_Items
))
28512 and then not Has_Null_State
28515 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
28516 & "global items"), N
, Spec_Id
);
28521 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28522 -- This ensures that the categorization of all refined global items is
28523 -- consistent with their role.
28525 Analyze_Global_In_Decl_Part
(N
);
28527 -- Perform all refinement checks with respect to completeness and mode
28530 if Serious_Errors_Detected
= Errors
then
28531 Check_Refined_Global_List
(Items
);
28534 -- Store the information that no constituent is used in the global
28535 -- refinement, prior to calling checking procedures which remove items
28536 -- from the list of constituents.
28540 and then No
(In_Out_Constits
)
28541 and then No
(Out_Constits
)
28542 and then No
(Proof_In_Constits
);
28544 -- For Input states with visible refinement, at least one constituent
28545 -- must be used as an Input in the global refinement.
28547 if Serious_Errors_Detected
= Errors
then
28548 Check_Input_States
;
28551 -- Verify all possible completion variants for In_Out states with
28552 -- visible refinement.
28554 if Serious_Errors_Detected
= Errors
then
28555 Check_In_Out_States
;
28558 -- For Output states with visible refinement, all constituents must be
28559 -- used as Outputs in the global refinement.
28561 if Serious_Errors_Detected
= Errors
then
28562 Check_Output_States
;
28565 -- For Proof_In states with visible refinement, at least one constituent
28566 -- must be used as Proof_In in the global refinement.
28568 if Serious_Errors_Detected
= Errors
then
28569 Check_Proof_In_States
;
28572 -- Emit errors for all constituents that belong to other states with
28573 -- visible refinement that do not appear in Global.
28575 if Serious_Errors_Detected
= Errors
then
28576 Report_Extra_Constituents
;
28579 -- Emit errors for all items in Global that are not repeated in the
28580 -- global refinement and for which there is no full visible refinement
28581 -- and, in the case of states with partial visible refinement, no
28582 -- constituent is mentioned in the global refinement.
28584 if Serious_Errors_Detected
= Errors
then
28585 Report_Missing_Items
;
28588 -- Emit an error if no constituent is used in the global refinement
28589 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28590 -- one may be issued by the checking procedures. Do not perform this
28591 -- check in an instance because it was already performed successfully
28592 -- in the generic template.
28594 if Serious_Errors_Detected
= Errors
28595 and then not In_Instance
28596 and then not Has_Null_State
28597 and then No_Constit
28599 SPARK_Msg_N
("missing refinement", N
);
28603 Set_Is_Analyzed_Pragma
(N
);
28604 end Analyze_Refined_Global_In_Decl_Part
;
28606 ----------------------------------------
28607 -- Analyze_Refined_State_In_Decl_Part --
28608 ----------------------------------------
28610 procedure Analyze_Refined_State_In_Decl_Part
28612 Freeze_Id
: Entity_Id
:= Empty
)
28614 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
28615 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28616 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
28618 Available_States
: Elist_Id
:= No_Elist
;
28619 -- A list of all abstract states defined in the package declaration that
28620 -- are available for refinement. The list is used to report unrefined
28623 Body_States
: Elist_Id
:= No_Elist
;
28624 -- A list of all hidden states that appear in the body of the related
28625 -- package. The list is used to report unused hidden states.
28627 Constituents_Seen
: Elist_Id
:= No_Elist
;
28628 -- A list that contains all constituents processed so far. The list is
28629 -- used to detect multiple uses of the same constituent.
28631 Freeze_Posted
: Boolean := False;
28632 -- A flag that controls the output of a freezing-related error (see use
28635 Refined_States_Seen
: Elist_Id
:= No_Elist
;
28636 -- A list that contains all refined states processed so far. The list is
28637 -- used to detect duplicate refinements.
28639 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
28640 -- Perform full analysis of a single refinement clause
28642 procedure Report_Unrefined_States
(States
: Elist_Id
);
28643 -- Emit errors for all unrefined abstract states found in list States
28645 -------------------------------
28646 -- Analyze_Refinement_Clause --
28647 -------------------------------
28649 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
28650 AR_Constit
: Entity_Id
:= Empty
;
28651 AW_Constit
: Entity_Id
:= Empty
;
28652 ER_Constit
: Entity_Id
:= Empty
;
28653 EW_Constit
: Entity_Id
:= Empty
;
28654 -- The entities of external constituents that contain one of the
28655 -- following enabled properties: Async_Readers, Async_Writers,
28656 -- Effective_Reads and Effective_Writes.
28658 External_Constit_Seen
: Boolean := False;
28659 -- Flag used to mark when at least one external constituent is part
28660 -- of the state refinement.
28662 Non_Null_Seen
: Boolean := False;
28663 Null_Seen
: Boolean := False;
28664 -- Flags used to detect multiple uses of null in a single clause or a
28665 -- mixture of null and non-null constituents.
28667 Part_Of_Constits
: Elist_Id
:= No_Elist
;
28668 -- A list of all candidate constituents subject to indicator Part_Of
28669 -- where the encapsulating state is the current state.
28672 State_Id
: Entity_Id
;
28673 -- The current state being refined
28675 procedure Analyze_Constituent
(Constit
: Node_Id
);
28676 -- Perform full analysis of a single constituent
28678 procedure Check_External_Property
28679 (Prop_Nam
: Name_Id
;
28681 Constit
: Entity_Id
);
28682 -- Determine whether a property denoted by name Prop_Nam is present
28683 -- in the refined state. Emit an error if this is not the case. Flag
28684 -- Enabled should be set when the property applies to the refined
28685 -- state. Constit denotes the constituent (if any) which introduces
28686 -- the property in the refinement.
28688 procedure Match_State
;
28689 -- Determine whether the state being refined appears in list
28690 -- Available_States. Emit an error when attempting to re-refine the
28691 -- state or when the state is not defined in the package declaration,
28692 -- otherwise remove the state from Available_States.
28694 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
28695 -- Emit errors for all unused Part_Of constituents in list Constits
28697 -------------------------
28698 -- Analyze_Constituent --
28699 -------------------------
28701 procedure Analyze_Constituent
(Constit
: Node_Id
) is
28702 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
28703 -- Determine whether constituent Constit denoted by its entity
28704 -- Constit_Id appears in Body_States. Emit an error when the
28705 -- constituent is not a valid hidden state of the related package
28706 -- or when it is used more than once. Otherwise remove the
28707 -- constituent from Body_States.
28709 -----------------------
28710 -- Match_Constituent --
28711 -----------------------
28713 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
28714 procedure Collect_Constituent
;
28715 -- Verify the legality of constituent Constit_Id and add it to
28716 -- the refinements of State_Id.
28718 -------------------------
28719 -- Collect_Constituent --
28720 -------------------------
28722 procedure Collect_Constituent
is
28723 Constits
: Elist_Id
;
28726 -- The Ghost policy in effect at the point of abstract state
28727 -- declaration and constituent must match (SPARK RM 6.9(15))
28729 Check_Ghost_Refinement
28730 (State
, State_Id
, Constit
, Constit_Id
);
28732 -- A synchronized state must be refined by a synchronized
28733 -- object or another synchronized state (SPARK RM 9.6).
28735 if Is_Synchronized_State
(State_Id
)
28736 and then not Is_Synchronized_Object
(Constit_Id
)
28737 and then not Is_Synchronized_State
(Constit_Id
)
28740 ("constituent of synchronized state & must be "
28741 & "synchronized", Constit
, State_Id
);
28744 -- Add the constituent to the list of processed items to aid
28745 -- with the detection of duplicates.
28747 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
28749 -- Collect the constituent in the list of refinement items
28750 -- and establish a relation between the refined state and
28753 Constits
:= Refinement_Constituents
(State_Id
);
28755 if No
(Constits
) then
28756 Constits
:= New_Elmt_List
;
28757 Set_Refinement_Constituents
(State_Id
, Constits
);
28760 Append_Elmt
(Constit_Id
, Constits
);
28761 Set_Encapsulating_State
(Constit_Id
, State_Id
);
28763 -- The state has at least one legal constituent, mark the
28764 -- start of the refinement region. The region ends when the
28765 -- body declarations end (see routine Analyze_Declarations).
28767 Set_Has_Visible_Refinement
(State_Id
);
28769 -- When the constituent is external, save its relevant
28770 -- property for further checks.
28772 if Async_Readers_Enabled
(Constit_Id
) then
28773 AR_Constit
:= Constit_Id
;
28774 External_Constit_Seen
:= True;
28777 if Async_Writers_Enabled
(Constit_Id
) then
28778 AW_Constit
:= Constit_Id
;
28779 External_Constit_Seen
:= True;
28782 if Effective_Reads_Enabled
(Constit_Id
) then
28783 ER_Constit
:= Constit_Id
;
28784 External_Constit_Seen
:= True;
28787 if Effective_Writes_Enabled
(Constit_Id
) then
28788 EW_Constit
:= Constit_Id
;
28789 External_Constit_Seen
:= True;
28791 end Collect_Constituent
;
28795 State_Elmt
: Elmt_Id
;
28797 -- Start of processing for Match_Constituent
28800 -- Detect a duplicate use of a constituent
28802 if Contains
(Constituents_Seen
, Constit_Id
) then
28804 ("duplicate use of constituent &", Constit
, Constit_Id
);
28808 -- The constituent is subject to a Part_Of indicator
28810 if Present
(Encapsulating_State
(Constit_Id
)) then
28811 if Encapsulating_State
(Constit_Id
) = State_Id
then
28812 Remove
(Part_Of_Constits
, Constit_Id
);
28813 Collect_Constituent
;
28815 -- The constituent is part of another state and is used
28816 -- incorrectly in the refinement of the current state.
28819 Error_Msg_Name_1
:= Chars
(State_Id
);
28821 ("& cannot act as constituent of state %",
28822 Constit
, Constit_Id
);
28824 ("\Part_Of indicator specifies encapsulator &",
28825 Constit
, Encapsulating_State
(Constit_Id
));
28830 Pack_Id
: Entity_Id
;
28831 Placement
: State_Space_Kind
;
28833 -- Find where the constituent lives with respect to the
28836 Find_Placement_In_State_Space
28837 (Item_Id
=> Constit_Id
,
28838 Placement
=> Placement
,
28839 Pack_Id
=> Pack_Id
);
28841 -- The constituent is either part of the hidden state of
28842 -- the package or part of the visible state of a private
28843 -- child package, but lacks a Part_Of indicator.
28845 if (Placement
= Private_State_Space
28846 and then Pack_Id
= Spec_Id
)
28848 (Placement
= Visible_State_Space
28849 and then Is_Child_Unit
(Pack_Id
)
28850 and then not Is_Generic_Unit
(Pack_Id
)
28851 and then Is_Private_Descendant
(Pack_Id
))
28853 Error_Msg_Name_1
:= Chars
(State_Id
);
28855 ("& cannot act as constituent of state %",
28856 Constit
, Constit_Id
);
28858 Sloc
(Enclosing_Declaration
(Constit_Id
));
28860 ("\missing Part_Of indicator # should specify "
28861 & "encapsulator &",
28862 Constit
, State_Id
);
28864 -- The only other source of legal constituents is the
28865 -- body state space of the related package.
28868 if Present
(Body_States
) then
28869 State_Elmt
:= First_Elmt
(Body_States
);
28870 while Present
(State_Elmt
) loop
28872 -- Consume a valid constituent to signal that it
28873 -- has been encountered.
28875 if Node
(State_Elmt
) = Constit_Id
then
28876 Remove_Elmt
(Body_States
, State_Elmt
);
28877 Collect_Constituent
;
28881 Next_Elmt
(State_Elmt
);
28885 -- At this point it is known that the constituent is
28886 -- not part of the package hidden state and cannot be
28887 -- used in a refinement (SPARK RM 7.2.2(9)).
28889 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28891 ("cannot use & in refinement, constituent is not a "
28892 & "hidden state of package %", Constit
, Constit_Id
);
28896 end Match_Constituent
;
28900 Constit_Id
: Entity_Id
;
28901 Constits
: Elist_Id
;
28903 -- Start of processing for Analyze_Constituent
28906 -- Detect multiple uses of null in a single refinement clause or a
28907 -- mixture of null and non-null constituents.
28909 if Nkind
(Constit
) = N_Null
then
28912 ("multiple null constituents not allowed", Constit
);
28914 elsif Non_Null_Seen
then
28916 ("cannot mix null and non-null constituents", Constit
);
28921 -- Collect the constituent in the list of refinement items
28923 Constits
:= Refinement_Constituents
(State_Id
);
28925 if No
(Constits
) then
28926 Constits
:= New_Elmt_List
;
28927 Set_Refinement_Constituents
(State_Id
, Constits
);
28930 Append_Elmt
(Constit
, Constits
);
28932 -- The state has at least one legal constituent, mark the
28933 -- start of the refinement region. The region ends when the
28934 -- body declarations end (see Analyze_Declarations).
28936 Set_Has_Visible_Refinement
(State_Id
);
28939 -- Non-null constituents
28942 Non_Null_Seen
:= True;
28946 ("cannot mix null and non-null constituents", Constit
);
28950 Resolve_State
(Constit
);
28952 -- Ensure that the constituent denotes a valid state or a
28953 -- whole object (SPARK RM 7.2.2(5)).
28955 if Is_Entity_Name
(Constit
) then
28956 Constit_Id
:= Entity_Of
(Constit
);
28958 -- When a constituent is declared after a subprogram body
28959 -- that caused freezing of the related contract where
28960 -- pragma Refined_State resides, the constituent appears
28961 -- undefined and carries Any_Id as its entity.
28963 -- package body Pack
28964 -- with Refined_State => (State => Constit)
28967 -- with Refined_Global => (Input => Constit)
28975 if Constit_Id
= Any_Id
then
28976 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
28978 -- Emit a specialized info message when the contract of
28979 -- the related package body was "frozen" by another body.
28980 -- Note that it is not possible to precisely identify why
28981 -- the constituent is undefined because it is not visible
28982 -- when pragma Refined_State is analyzed. This message is
28983 -- a reasonable approximation.
28985 if Present
(Freeze_Id
) and then not Freeze_Posted
then
28986 Freeze_Posted
:= True;
28988 Error_Msg_Name_1
:= Chars
(Body_Id
);
28989 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28991 ("body & declared # freezes the contract of %",
28994 ("\all constituents must be declared before body #",
28997 -- A misplaced constituent is a critical error because
28998 -- pragma Refined_Depends or Refined_Global depends on
28999 -- the proper link between a state and a constituent.
29000 -- Stop the compilation, as this leads to a multitude
29001 -- of misleading cascaded errors.
29003 raise Unrecoverable_Error
;
29006 -- The constituent is a valid state or object
29008 elsif Ekind
(Constit_Id
) in
29009 E_Abstract_State | E_Constant | E_Variable
29011 Match_Constituent
(Constit_Id
);
29013 -- The variable may eventually become a constituent of a
29014 -- single protected/task type. Record the reference now
29015 -- and verify its legality when analyzing the contract of
29016 -- the variable (SPARK RM 9.3).
29018 if Ekind
(Constit_Id
) = E_Variable
then
29019 Record_Possible_Part_Of_Reference
29020 (Var_Id
=> Constit_Id
,
29024 -- Otherwise the constituent is illegal
29028 ("constituent & must denote object or state",
29029 Constit
, Constit_Id
);
29032 -- The constituent is illegal
29035 SPARK_Msg_N
("malformed constituent", Constit
);
29038 end Analyze_Constituent
;
29040 -----------------------------
29041 -- Check_External_Property --
29042 -----------------------------
29044 procedure Check_External_Property
29045 (Prop_Nam
: Name_Id
;
29047 Constit
: Entity_Id
)
29050 -- The property is missing in the declaration of the state, but
29051 -- a constituent is introducing it in the state refinement
29052 -- (SPARK RM 7.2.8(2)).
29054 if not Enabled
and then Present
(Constit
) then
29055 Error_Msg_Name_1
:= Prop_Nam
;
29056 Error_Msg_Name_2
:= Chars
(State_Id
);
29058 ("constituent & introduces external property % in refinement "
29059 & "of state %", State
, Constit
);
29061 Error_Msg_Sloc
:= Sloc
(State_Id
);
29063 ("\property is missing in abstract state declaration #",
29066 end Check_External_Property
;
29072 procedure Match_State
is
29073 State_Elmt
: Elmt_Id
;
29076 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
29078 if Contains
(Refined_States_Seen
, State_Id
) then
29080 ("duplicate refinement of state &", State
, State_Id
);
29084 -- Inspect the abstract states defined in the package declaration
29085 -- looking for a match.
29087 State_Elmt
:= First_Elmt
(Available_States
);
29088 while Present
(State_Elmt
) loop
29090 -- A valid abstract state is being refined in the body. Add
29091 -- the state to the list of processed refined states to aid
29092 -- with the detection of duplicate refinements. Remove the
29093 -- state from Available_States to signal that it has already
29096 if Node
(State_Elmt
) = State_Id
then
29097 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
29098 Remove_Elmt
(Available_States
, State_Elmt
);
29102 Next_Elmt
(State_Elmt
);
29105 -- If we get here, we are refining a state that is not defined in
29106 -- the package declaration.
29108 Error_Msg_Name_1
:= Chars
(Spec_Id
);
29110 ("cannot refine state, & is not defined in package %",
29114 --------------------------------
29115 -- Report_Unused_Constituents --
29116 --------------------------------
29118 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
29119 Constit_Elmt
: Elmt_Id
;
29120 Constit_Id
: Entity_Id
;
29121 Posted
: Boolean := False;
29124 if Present
(Constits
) then
29125 Constit_Elmt
:= First_Elmt
(Constits
);
29126 while Present
(Constit_Elmt
) loop
29127 Constit_Id
:= Node
(Constit_Elmt
);
29129 -- Generate an error message of the form:
29131 -- state ... has unused Part_Of constituents
29132 -- abstract state ... defined at ...
29133 -- constant ... defined at ...
29134 -- variable ... defined at ...
29139 ("state & has unused Part_Of constituents",
29143 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
29145 if Ekind
(Constit_Id
) = E_Abstract_State
then
29147 ("\abstract state & defined #", State
, Constit_Id
);
29149 elsif Ekind
(Constit_Id
) = E_Constant
then
29151 ("\constant & defined #", State
, Constit_Id
);
29154 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
29155 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
29158 Next_Elmt
(Constit_Elmt
);
29161 end Report_Unused_Constituents
;
29163 -- Local declarations
29165 Body_Ref
: Node_Id
;
29166 Body_Ref_Elmt
: Elmt_Id
;
29168 Extra_State
: Node_Id
;
29170 -- Start of processing for Analyze_Refinement_Clause
29173 -- A refinement clause appears as a component association where the
29174 -- sole choice is the state and the expressions are the constituents.
29175 -- This is a syntax error, always report.
29177 if Nkind
(Clause
) /= N_Component_Association
then
29178 Error_Msg_N
("malformed state refinement clause", Clause
);
29182 -- Analyze the state name of a refinement clause
29184 State
:= First
(Choices
(Clause
));
29187 Resolve_State
(State
);
29189 -- Ensure that the state name denotes a valid abstract state that is
29190 -- defined in the spec of the related package.
29192 if Is_Entity_Name
(State
) then
29193 State_Id
:= Entity_Of
(State
);
29195 -- When the abstract state is undefined, it appears as Any_Id. Do
29196 -- not continue with the analysis of the clause.
29198 if State_Id
= Any_Id
then
29201 -- Catch any attempts to re-refine a state or refine a state that
29202 -- is not defined in the package declaration.
29204 elsif Ekind
(State_Id
) = E_Abstract_State
then
29208 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
29212 -- References to a state with visible refinement are illegal.
29213 -- When nested packages are involved, detecting such references is
29214 -- tricky because pragma Refined_State is analyzed later than the
29215 -- offending pragma Depends or Global. References that occur in
29216 -- such nested context are stored in a list. Emit errors for all
29217 -- references found in Body_References (SPARK RM 6.1.4(8)).
29219 if Present
(Body_References
(State_Id
)) then
29220 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
29221 while Present
(Body_Ref_Elmt
) loop
29222 Body_Ref
:= Node
(Body_Ref_Elmt
);
29224 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
29225 Error_Msg_Sloc
:= Sloc
(State
);
29226 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
29228 Next_Elmt
(Body_Ref_Elmt
);
29232 -- The state name is illegal. This is a syntax error, always report.
29235 Error_Msg_N
("malformed state name in refinement clause", State
);
29239 -- A refinement clause may only refine one state at a time
29241 Extra_State
:= Next
(State
);
29243 if Present
(Extra_State
) then
29245 ("refinement clause cannot cover multiple states", Extra_State
);
29248 -- Replicate the Part_Of constituents of the refined state because
29249 -- the algorithm will consume items.
29251 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
29253 -- Analyze all constituents of the refinement. Multiple constituents
29254 -- appear as an aggregate.
29256 Constit
:= Expression
(Clause
);
29258 if Nkind
(Constit
) = N_Aggregate
then
29259 if Present
(Component_Associations
(Constit
)) then
29261 ("constituents of refinement clause must appear in "
29262 & "positional form", Constit
);
29264 else pragma Assert
(Present
(Expressions
(Constit
)));
29265 Constit
:= First
(Expressions
(Constit
));
29266 while Present
(Constit
) loop
29267 Analyze_Constituent
(Constit
);
29272 -- Various forms of a single constituent. Note that these may include
29273 -- malformed constituents.
29276 Analyze_Constituent
(Constit
);
29279 -- Verify that external constituents do not introduce new external
29280 -- property in the state refinement (SPARK RM 7.2.8(2)).
29282 if Is_External_State
(State_Id
) then
29283 Check_External_Property
29284 (Prop_Nam
=> Name_Async_Readers
,
29285 Enabled
=> Async_Readers_Enabled
(State_Id
),
29286 Constit
=> AR_Constit
);
29288 Check_External_Property
29289 (Prop_Nam
=> Name_Async_Writers
,
29290 Enabled
=> Async_Writers_Enabled
(State_Id
),
29291 Constit
=> AW_Constit
);
29293 Check_External_Property
29294 (Prop_Nam
=> Name_Effective_Reads
,
29295 Enabled
=> Effective_Reads_Enabled
(State_Id
),
29296 Constit
=> ER_Constit
);
29298 Check_External_Property
29299 (Prop_Nam
=> Name_Effective_Writes
,
29300 Enabled
=> Effective_Writes_Enabled
(State_Id
),
29301 Constit
=> EW_Constit
);
29303 -- When a refined state is not external, it should not have external
29304 -- constituents (SPARK RM 7.2.8(1)).
29306 elsif External_Constit_Seen
then
29308 ("non-external state & cannot contain external constituents in "
29309 & "refinement", State
, State_Id
);
29312 -- Ensure that all Part_Of candidate constituents have been mentioned
29313 -- in the refinement clause.
29315 Report_Unused_Constituents
(Part_Of_Constits
);
29317 -- Avoid a cascading error reporting a missing refinement by adding a
29318 -- dummy constituent.
29320 if No
(Refinement_Constituents
(State_Id
)) then
29321 Set_Refinement_Constituents
(State_Id
, New_Elmt_List
(Any_Id
));
29324 -- At this point the refinement might be dummy, but must be
29325 -- well-formed, to prevent cascaded errors.
29327 pragma Assert
(Has_Null_Refinement
(State_Id
)
29329 Has_Non_Null_Refinement
(State_Id
));
29330 end Analyze_Refinement_Clause
;
29332 -----------------------------
29333 -- Report_Unrefined_States --
29334 -----------------------------
29336 procedure Report_Unrefined_States
(States
: Elist_Id
) is
29337 State_Elmt
: Elmt_Id
;
29340 if Present
(States
) then
29341 State_Elmt
:= First_Elmt
(States
);
29342 while Present
(State_Elmt
) loop
29344 ("abstract state & must be refined", Node
(State_Elmt
));
29346 Next_Elmt
(State_Elmt
);
29349 end Report_Unrefined_States
;
29351 -- Local declarations
29353 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
29356 -- Start of processing for Analyze_Refined_State_In_Decl_Part
29359 -- Do not analyze the pragma multiple times
29361 if Is_Analyzed_Pragma
(N
) then
29365 -- Save the scenario for examination by the ABE Processing phase
29367 Record_Elaboration_Scenario
(N
);
29369 -- Replicate the abstract states declared by the package because the
29370 -- matching algorithm will consume states.
29372 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
29374 -- Gather all abstract states and objects declared in the visible
29375 -- state space of the package body. These items must be utilized as
29376 -- constituents in a state refinement.
29378 Body_States
:= Collect_Body_States
(Body_Id
);
29380 -- Multiple non-null state refinements appear as an aggregate
29382 if Nkind
(Clauses
) = N_Aggregate
then
29383 if Present
(Expressions
(Clauses
)) then
29385 ("state refinements must appear as component associations",
29388 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
29389 Clause
:= First
(Component_Associations
(Clauses
));
29390 while Present
(Clause
) loop
29391 Analyze_Refinement_Clause
(Clause
);
29396 -- Various forms of a single state refinement. Note that these may
29397 -- include malformed refinements.
29400 Analyze_Refinement_Clause
(Clauses
);
29403 -- List all abstract states that were left unrefined
29405 Report_Unrefined_States
(Available_States
);
29407 Set_Is_Analyzed_Pragma
(N
);
29408 end Analyze_Refined_State_In_Decl_Part
;
29410 ---------------------------------------------
29411 -- Analyze_Subprogram_Variant_In_Decl_Part --
29412 ---------------------------------------------
29414 -- WARNING: This routine manages Ghost regions. Return statements must be
29415 -- replaced by gotos which jump to the end of the routine and restore the
29418 procedure Analyze_Subprogram_Variant_In_Decl_Part
29420 Freeze_Id
: Entity_Id
:= Empty
)
29422 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29423 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29425 procedure Analyze_Variant
(Variant
: Node_Id
);
29426 -- Verify the legality of a single contract case
29428 ---------------------
29429 -- Analyze_Variant --
29430 ---------------------
29432 procedure Analyze_Variant
(Variant
: Node_Id
) is
29433 Direction
: Node_Id
;
29436 Extra_Direction
: Node_Id
;
29439 if Nkind
(Variant
) /= N_Component_Association
then
29440 Error_Msg_N
("wrong syntax in subprogram variant", Variant
);
29444 Direction
:= First
(Choices
(Variant
));
29445 Expr
:= Expression
(Variant
);
29447 -- Each variant must have exactly one direction
29449 Extra_Direction
:= Next
(Direction
);
29451 if Present
(Extra_Direction
) then
29453 ("subprogram variant case must have exactly one direction",
29457 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
29459 if Nkind
(Direction
) = N_Identifier
then
29460 if Chars
(Direction
) /= Name_Decreases
29462 Chars
(Direction
) /= Name_Increases
29464 Error_Msg_N
("wrong direction", Direction
);
29467 Error_Msg_N
("wrong syntax", Direction
);
29470 Errors
:= Serious_Errors_Detected
;
29471 Preanalyze_Assert_Expression
(Expr
, Any_Discrete
);
29473 -- Emit a clarification message when the variant expression
29474 -- contains at least one undefined reference, possibly due
29475 -- to contract freezing.
29477 if Errors
/= Serious_Errors_Detected
29478 and then Present
(Freeze_Id
)
29479 and then Has_Undefined_Reference
(Expr
)
29481 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
29483 end Analyze_Variant
;
29487 Variants
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
29489 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
29490 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
29491 -- Save the Ghost-related attributes to restore on exit
29494 Restore_Scope
: Boolean := False;
29496 -- Start of processing for Analyze_Subprogram_Variant_In_Decl_Part
29499 -- Do not analyze the pragma multiple times
29501 if Is_Analyzed_Pragma
(N
) then
29505 -- Set the Ghost mode in effect from the pragma. Due to the delayed
29506 -- analysis of the pragma, the Ghost mode at point of declaration and
29507 -- point of analysis may not necessarily be the same. Use the mode in
29508 -- effect at the point of declaration.
29510 Set_Ghost_Mode
(N
);
29512 -- Single and multiple contract cases must appear in aggregate form. If
29513 -- this is not the case, then either the parser of the analysis of the
29514 -- pragma failed to produce an aggregate, e.g. when the contract is
29515 -- "null" or a "(null record)".
29518 (if Nkind
(Variants
) = N_Aggregate
29519 then Null_Record_Present
(Variants
)
29520 xor (Present
(Component_Associations
(Variants
))
29522 Present
(Expressions
(Variants
)))
29523 else Nkind
(Variants
) = N_Null
);
29525 -- Only "change_direction => discrete_expression" clauses are allowed
29527 if Nkind
(Variants
) = N_Aggregate
29528 and then Present
(Component_Associations
(Variants
))
29529 and then No
(Expressions
(Variants
))
29532 -- Check that the expression is a proper aggregate (no parentheses)
29534 if Paren_Count
(Variants
) /= 0 then
29535 Error_Msg_F
-- CODEFIX
29536 ("redundant parentheses", Variants
);
29539 -- Ensure that the formal parameters are visible when analyzing all
29540 -- clauses. This falls out of the general rule of aspects pertaining
29541 -- to subprogram declarations.
29543 if not In_Open_Scopes
(Spec_Id
) then
29544 Restore_Scope
:= True;
29545 Push_Scope
(Spec_Id
);
29547 if Is_Generic_Subprogram
(Spec_Id
) then
29548 Install_Generic_Formals
(Spec_Id
);
29550 Install_Formals
(Spec_Id
);
29554 Variant
:= First
(Component_Associations
(Variants
));
29555 while Present
(Variant
) loop
29556 Analyze_Variant
(Variant
);
29560 if Restore_Scope
then
29564 -- Otherwise the pragma is illegal
29567 Error_Msg_N
("wrong syntax for subprogram variant", N
);
29570 Set_Is_Analyzed_Pragma
(N
);
29572 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
29573 end Analyze_Subprogram_Variant_In_Decl_Part
;
29575 ------------------------------------
29576 -- Analyze_Test_Case_In_Decl_Part --
29577 ------------------------------------
29579 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
29580 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
29581 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29583 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
29584 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
29585 -- denoted by Arg_Nam.
29587 ------------------------------
29588 -- Preanalyze_Test_Case_Arg --
29589 ------------------------------
29591 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
29595 -- Preanalyze the original aspect argument for a generic subprogram
29596 -- to properly capture global references.
29598 if Is_Generic_Subprogram
(Spec_Id
) then
29602 Arg_Nam
=> Arg_Nam
,
29603 From_Aspect
=> True);
29605 if Present
(Arg
) then
29606 Preanalyze_Assert_Expression
29607 (Expression
(Arg
), Standard_Boolean
);
29611 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
29613 if Present
(Arg
) then
29614 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
29616 end Preanalyze_Test_Case_Arg
;
29620 Restore_Scope
: Boolean := False;
29622 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29625 -- Do not analyze the pragma multiple times
29627 if Is_Analyzed_Pragma
(N
) then
29631 -- Ensure that the formal parameters are visible when analyzing all
29632 -- clauses. This falls out of the general rule of aspects pertaining
29633 -- to subprogram declarations.
29635 if not In_Open_Scopes
(Spec_Id
) then
29636 Restore_Scope
:= True;
29637 Push_Scope
(Spec_Id
);
29639 if Is_Generic_Subprogram
(Spec_Id
) then
29640 Install_Generic_Formals
(Spec_Id
);
29642 Install_Formals
(Spec_Id
);
29646 Preanalyze_Test_Case_Arg
(Name_Requires
);
29647 Preanalyze_Test_Case_Arg
(Name_Ensures
);
29649 if Restore_Scope
then
29653 -- Currently it is not possible to inline pre/postconditions on a
29654 -- subprogram subject to pragma Inline_Always.
29656 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
29658 Set_Is_Analyzed_Pragma
(N
);
29659 end Analyze_Test_Case_In_Decl_Part
;
29665 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
29670 if Present
(List
) then
29671 Elmt
:= First_Elmt
(List
);
29672 while Present
(Elmt
) loop
29673 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
29676 Id
:= Entity_Of
(Node
(Elmt
));
29679 if Id
= Item_Id
then
29690 -----------------------------------
29691 -- Build_Pragma_Check_Equivalent --
29692 -----------------------------------
29694 function Build_Pragma_Check_Equivalent
29696 Subp_Id
: Entity_Id
:= Empty
;
29697 Inher_Id
: Entity_Id
:= Empty
;
29698 Keep_Pragma_Id
: Boolean := False) return Node_Id
29700 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
29701 -- Detect whether node N references a formal parameter subject to
29702 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29703 -- to False to suppress the generation of a reference when analyzing
29706 ------------------------
29707 -- Suppress_Reference --
29708 ------------------------
29710 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
29711 Formal
: Entity_Id
;
29714 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29715 Formal
:= Entity
(N
);
29717 -- The formal parameter is subject to pragma Unreferenced. Prevent
29718 -- the generation of references by resetting the Comes_From_Source
29721 if Is_Formal
(Formal
)
29722 and then Has_Pragma_Unreferenced
(Formal
)
29724 Set_Comes_From_Source
(N
, False);
29729 end Suppress_Reference
;
29731 procedure Suppress_References
is
29732 new Traverse_Proc
(Suppress_Reference
);
29736 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
29737 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29738 Check_Prag
: Node_Id
;
29742 -- Start of processing for Build_Pragma_Check_Equivalent
29745 -- When the pre- or postcondition is inherited, map the formals of the
29746 -- inherited subprogram to those of the current subprogram. In addition,
29747 -- map primitive operations of the parent type into the corresponding
29748 -- primitive operations of the descendant.
29750 if Present
(Inher_Id
) then
29751 pragma Assert
(Present
(Subp_Id
));
29753 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
29755 -- Use generic machinery to copy inherited pragma, as if it were an
29756 -- instantiation, resetting source locations appropriately, so that
29757 -- expressions inside the inherited pragma use chained locations.
29758 -- This is used in particular in GNATprove to locate precisely
29759 -- messages on a given inherited pragma.
29761 Set_Copied_Sloc_For_Inherited_Pragma
29762 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
29763 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29765 -- Build the inherited class-wide condition
29767 Build_Class_Wide_Expression
29768 (Pragma_Or_Expr
=> Check_Prag
,
29770 Par_Subp
=> Inher_Id
,
29771 Adjust_Sloc
=> True);
29773 -- If not an inherited condition simply copy the original pragma
29776 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29779 -- Mark the pragma as being internally generated and reset the Analyzed
29782 Set_Analyzed
(Check_Prag
, False);
29783 Set_Comes_From_Source
(Check_Prag
, False);
29785 -- The tree of the original pragma may contain references to the
29786 -- formal parameters of the related subprogram. At the same time
29787 -- the corresponding body may mark the formals as unreferenced:
29789 -- procedure Proc (Formal : ...)
29790 -- with Pre => Formal ...;
29792 -- procedure Proc (Formal : ...) is
29793 -- pragma Unreferenced (Formal);
29796 -- This creates problems because all pragma Check equivalents are
29797 -- analyzed at the end of the body declarations. Since all source
29798 -- references have already been accounted for, reset any references
29799 -- to such formals in the generated pragma Check equivalent.
29801 Suppress_References
(Check_Prag
);
29803 if Present
(Corresponding_Aspect
(Prag
)) then
29804 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
29809 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29810 -- the copied pragma in the newly created pragma, convert the copy into
29811 -- pragma Check by correcting the name and adding a check_kind argument.
29813 if not Keep_Pragma_Id
then
29814 Set_Class_Present
(Check_Prag
, False);
29816 Set_Pragma_Identifier
29817 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
29819 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
29820 Make_Pragma_Argument_Association
(Loc
,
29821 Expression
=> Make_Identifier
(Loc
, Nam
)));
29824 -- Update the error message when the pragma is inherited
29826 if Present
(Inher_Id
) then
29827 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
29829 if Chars
(Msg_Arg
) = Name_Message
then
29830 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
29832 -- Insert "inherited" to improve the error message
29834 if Name_Buffer
(1 .. 8) = "failed p" then
29835 Insert_Str_In_Name_Buffer
("inherited ", 8);
29836 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
29842 end Build_Pragma_Check_Equivalent
;
29844 -----------------------------
29845 -- Check_Applicable_Policy --
29846 -----------------------------
29848 procedure Check_Applicable_Policy
(N
: Node_Id
) is
29852 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
29855 -- No effect if not valid assertion kind name
29857 if not Is_Valid_Assertion_Kind
(Ename
) then
29861 -- Loop through entries in check policy list
29863 PP
:= Opt
.Check_Policy_List
;
29864 while Present
(PP
) loop
29866 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29867 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29871 or else Pnm
= Name_Assertion
29872 or else (Pnm
= Name_Statement_Assertions
29873 and then Ename
in Name_Assert
29874 | Name_Assert_And_Cut
29876 | Name_Loop_Invariant
29877 | Name_Loop_Variant
)
29879 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
29885 -- In CodePeer mode and GNATprove mode, we need to
29886 -- consider all assertions, unless they are disabled.
29887 -- Force Is_Checked on ignored assertions, in particular
29888 -- because transformations of the AST may depend on
29889 -- assertions being checked (e.g. the translation of
29890 -- attribute 'Loop_Entry).
29892 if CodePeer_Mode
or GNATprove_Mode
then
29893 Set_Is_Checked
(N
, True);
29894 Set_Is_Ignored
(N
, False);
29896 Set_Is_Checked
(N
, False);
29897 Set_Is_Ignored
(N
, True);
29903 Set_Is_Checked
(N
, True);
29904 Set_Is_Ignored
(N
, False);
29906 when Name_Disable
=>
29907 Set_Is_Ignored
(N
, True);
29908 Set_Is_Checked
(N
, False);
29909 Set_Is_Disabled
(N
, True);
29911 -- That should be exhaustive, the null here is a defence
29912 -- against a malformed tree from previous errors.
29921 PP
:= Next_Pragma
(PP
);
29925 -- If there are no specific entries that matched, then we let the
29926 -- setting of assertions govern. Note that this provides the needed
29927 -- compatibility with the RM for the cases of assertion, invariant,
29928 -- precondition, predicate, and postcondition. Note also that
29929 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29931 if Assertions_Enabled
then
29932 Set_Is_Checked
(N
, True);
29933 Set_Is_Ignored
(N
, False);
29935 Set_Is_Checked
(N
, False);
29936 Set_Is_Ignored
(N
, True);
29938 end Check_Applicable_Policy
;
29940 -------------------------------
29941 -- Check_External_Properties --
29942 -------------------------------
29944 procedure Check_External_Properties
29951 type Properties
is array (Positive range 1 .. 4) of Boolean;
29952 type Combinations
is array (Positive range <>) of Properties
;
29953 -- Arrays of Async_Readers, Async_Writers, Effective_Writes and
29954 -- Effective_Reads properties and their combinations, respectively.
29956 Specified
: constant Properties
:= (AR
, AW
, EW
, ER
);
29957 -- External properties, as given by the Item pragma
29959 Allowed
: constant Combinations
:=
29960 (1 => (True, False, True, False),
29961 2 => (False, True, False, True),
29962 3 => (True, False, False, False),
29963 4 => (False, True, False, False),
29964 5 => (True, True, True, False),
29965 6 => (True, True, False, True),
29966 7 => (True, True, False, False),
29967 8 => (True, True, True, True));
29968 -- Allowed combinations, as listed in the SPARK RM 7.1.2(6) table
29971 -- Check if the specified properties match any of the allowed
29972 -- combination; if not, then emit an error.
29974 for J
in Allowed
'Range loop
29975 if Specified
= Allowed
(J
) then
29981 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29983 end Check_External_Properties
;
29989 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
29993 -- Loop through entries in check policy list
29995 PP
:= Opt
.Check_Policy_List
;
29996 while Present
(PP
) loop
29998 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29999 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
30003 or else (Pnm
= Name_Assertion
30004 and then Is_Valid_Assertion_Kind
(Nam
))
30005 or else (Pnm
= Name_Statement_Assertions
30006 and then Nam
in Name_Assert
30007 | Name_Assert_And_Cut
30009 | Name_Loop_Invariant
30010 | Name_Loop_Variant
)
30012 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
30021 return Name_Ignore
;
30023 when Name_Disable
=>
30024 return Name_Disable
;
30027 raise Program_Error
;
30031 PP
:= Next_Pragma
(PP
);
30036 -- If there are no specific entries that matched, then we let the
30037 -- setting of assertions govern. Note that this provides the needed
30038 -- compatibility with the RM for the cases of assertion, invariant,
30039 -- precondition, predicate, and postcondition.
30041 if Assertions_Enabled
then
30044 return Name_Ignore
;
30048 ---------------------------
30049 -- Check_Missing_Part_Of --
30050 ---------------------------
30052 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
30053 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
30054 -- Determine whether a package denoted by Pack_Id declares at least one
30057 -----------------------
30058 -- Has_Visible_State --
30059 -----------------------
30061 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
30062 Item_Id
: Entity_Id
;
30065 -- Traverse the entity chain of the package trying to find at least
30066 -- one visible abstract state, variable or a package [instantiation]
30067 -- that declares a visible state.
30069 Item_Id
:= First_Entity
(Pack_Id
);
30070 while Present
(Item_Id
)
30071 and then not In_Private_Part
(Item_Id
)
30073 -- Do not consider internally generated items
30075 if not Comes_From_Source
(Item_Id
) then
30078 -- Do not consider generic formals or their corresponding actuals
30079 -- because they are not part of a visible state. Note that both
30080 -- entities are marked as hidden.
30082 elsif Is_Hidden
(Item_Id
) then
30085 -- A visible state has been found. Note that constants are not
30086 -- considered here because it is not possible to determine whether
30087 -- they depend on variable input. This check is left to the SPARK
30090 elsif Ekind
(Item_Id
) in E_Abstract_State | E_Variable
then
30093 -- Recursively peek into nested packages and instantiations
30095 elsif Ekind
(Item_Id
) = E_Package
30096 and then Has_Visible_State
(Item_Id
)
30101 Next_Entity
(Item_Id
);
30105 end Has_Visible_State
;
30109 Pack_Id
: Entity_Id
;
30110 Placement
: State_Space_Kind
;
30112 -- Start of processing for Check_Missing_Part_Of
30115 -- Do not consider abstract states, variables or package instantiations
30116 -- coming from an instance as those always inherit the Part_Of indicator
30117 -- of the instance itself.
30119 if In_Instance
then
30122 -- Do not consider internally generated entities as these can never
30123 -- have a Part_Of indicator.
30125 elsif not Comes_From_Source
(Item_Id
) then
30128 -- Perform these checks only when SPARK_Mode is enabled as they will
30129 -- interfere with standard Ada rules and produce false positives.
30131 elsif SPARK_Mode
/= On
then
30134 -- Do not consider constants, because the compiler cannot accurately
30135 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
30136 -- act as a hidden state of a package.
30138 elsif Ekind
(Item_Id
) = E_Constant
then
30142 -- Find where the abstract state, variable or package instantiation
30143 -- lives with respect to the state space.
30145 Find_Placement_In_State_Space
30146 (Item_Id
=> Item_Id
,
30147 Placement
=> Placement
,
30148 Pack_Id
=> Pack_Id
);
30150 -- Items that appear in a non-package construct (subprogram, block, etc)
30151 -- do not require a Part_Of indicator because they can never act as a
30154 if Placement
= Not_In_Package
then
30157 -- An item declared in the body state space of a package always act as a
30158 -- constituent and does not need explicit Part_Of indicator.
30160 elsif Placement
= Body_State_Space
then
30163 -- In general an item declared in the visible state space of a package
30164 -- does not require a Part_Of indicator. The only exception is when the
30165 -- related package is a nongeneric private child unit, in which case
30166 -- Part_Of must denote a state in the parent unit or in one of its
30169 elsif Placement
= Visible_State_Space
then
30170 if Is_Child_Unit
(Pack_Id
)
30171 and then not Is_Generic_Unit
(Pack_Id
)
30172 and then Is_Private_Descendant
(Pack_Id
)
30174 -- A package instantiation does not need a Part_Of indicator when
30175 -- the related generic template has no visible state.
30177 if Ekind
(Item_Id
) = E_Package
30178 and then Is_Generic_Instance
(Item_Id
)
30179 and then not Has_Visible_State
(Item_Id
)
30183 -- All other cases require Part_Of
30187 ("indicator Part_Of is required in this context "
30188 & "(SPARK RM 7.2.6(3))", Item_Id
);
30189 Error_Msg_Name_1
:= Chars
(Pack_Id
);
30191 ("\& is declared in the visible part of private child "
30192 & "unit %", Item_Id
);
30196 -- When the item appears in the private state space of a package, it
30197 -- must be a part of some state declared by the said package.
30199 else pragma Assert
(Placement
= Private_State_Space
);
30201 -- The related package does not declare a state, the item cannot act
30202 -- as a Part_Of constituent.
30204 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
30207 -- A package instantiation does not need a Part_Of indicator when the
30208 -- related generic template has no visible state.
30210 elsif Ekind
(Item_Id
) = E_Package
30211 and then Is_Generic_Instance
(Item_Id
)
30212 and then not Has_Visible_State
(Item_Id
)
30216 -- All other cases require Part_Of
30220 ("indicator Part_Of is required in this context "
30221 & "(SPARK RM 7.2.6(2))", Item_Id
);
30222 Error_Msg_Name_1
:= Chars
(Pack_Id
);
30224 ("\& is declared in the private part of package %", Item_Id
);
30227 end Check_Missing_Part_Of
;
30229 ---------------------------------------------------
30230 -- Check_Postcondition_Use_In_Inlined_Subprogram --
30231 ---------------------------------------------------
30233 procedure Check_Postcondition_Use_In_Inlined_Subprogram
30235 Spec_Id
: Entity_Id
)
30238 if Warn_On_Redundant_Constructs
30239 and then Has_Pragma_Inline_Always
(Spec_Id
)
30240 and then Assertions_Enabled
30242 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30244 if From_Aspect_Specification
(Prag
) then
30246 ("aspect % not enforced on inlined subprogram &?r?",
30247 Corresponding_Aspect
(Prag
), Spec_Id
);
30250 ("pragma % not enforced on inlined subprogram &?r?",
30254 end Check_Postcondition_Use_In_Inlined_Subprogram
;
30256 -------------------------------------
30257 -- Check_State_And_Constituent_Use --
30258 -------------------------------------
30260 procedure Check_State_And_Constituent_Use
30261 (States
: Elist_Id
;
30262 Constits
: Elist_Id
;
30265 Constit_Elmt
: Elmt_Id
;
30266 Constit_Id
: Entity_Id
;
30267 State_Id
: Entity_Id
;
30270 -- Nothing to do if there are no states or constituents
30272 if No
(States
) or else No
(Constits
) then
30276 -- Inspect the list of constituents and try to determine whether its
30277 -- encapsulating state is in list States.
30279 Constit_Elmt
:= First_Elmt
(Constits
);
30280 while Present
(Constit_Elmt
) loop
30281 Constit_Id
:= Node
(Constit_Elmt
);
30283 -- Determine whether the constituent is part of an encapsulating
30284 -- state that appears in the same context and if this is the case,
30285 -- emit an error (SPARK RM 7.2.6(7)).
30287 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
30289 if Present
(State_Id
) then
30290 Error_Msg_Name_1
:= Chars
(Constit_Id
);
30292 ("cannot mention state & and its constituent % in the same "
30293 & "context", Context
, State_Id
);
30297 Next_Elmt
(Constit_Elmt
);
30299 end Check_State_And_Constituent_Use
;
30301 ---------------------------------------------
30302 -- Collect_Inherited_Class_Wide_Conditions --
30303 ---------------------------------------------
30305 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
30306 Parent_Subp
: constant Entity_Id
:=
30307 Ultimate_Alias
(Overridden_Operation
(Subp
));
30308 -- The Overridden_Operation may itself be inherited and as such have no
30309 -- explicit contract.
30311 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
30312 In_Spec_Expr
: Boolean := In_Spec_Expression
;
30313 Installed
: Boolean;
30315 New_Prag
: Node_Id
;
30318 Installed
:= False;
30320 -- Iterate over the contract of the overridden subprogram to find all
30321 -- inherited class-wide pre- and postconditions.
30323 if Present
(Prags
) then
30324 Prag
:= Pre_Post_Conditions
(Prags
);
30326 while Present
(Prag
) loop
30327 if Pragma_Name_Unmapped
(Prag
)
30328 in Name_Precondition | Name_Postcondition
30329 and then Class_Present
(Prag
)
30331 -- The generated pragma must be analyzed in the context of
30332 -- the subprogram, to make its formals visible. In addition,
30333 -- we must inhibit freezing and full analysis because the
30334 -- controlling type of the subprogram is not frozen yet, and
30335 -- may have further primitives.
30337 if not Installed
then
30340 Install_Formals
(Subp
);
30341 In_Spec_Expr
:= In_Spec_Expression
;
30342 In_Spec_Expression
:= True;
30346 Build_Pragma_Check_Equivalent
30347 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
30349 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
30350 Preanalyze
(New_Prag
);
30352 -- Prevent further analysis in subsequent processing of the
30353 -- current list of declarations
30355 Set_Analyzed
(New_Prag
);
30358 Prag
:= Next_Pragma
(Prag
);
30362 In_Spec_Expression
:= In_Spec_Expr
;
30366 end Collect_Inherited_Class_Wide_Conditions
;
30368 ---------------------------------------
30369 -- Collect_Subprogram_Inputs_Outputs --
30370 ---------------------------------------
30372 procedure Collect_Subprogram_Inputs_Outputs
30373 (Subp_Id
: Entity_Id
;
30374 Synthesize
: Boolean := False;
30375 Subp_Inputs
: in out Elist_Id
;
30376 Subp_Outputs
: in out Elist_Id
;
30377 Global_Seen
: out Boolean)
30379 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
30380 -- Collect all relevant items from a dependency clause
30382 procedure Collect_Global_List
30384 Mode
: Name_Id
:= Name_Input
);
30385 -- Collect all relevant items from a global list
30387 -------------------------------
30388 -- Collect_Dependency_Clause --
30389 -------------------------------
30391 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
30392 procedure Collect_Dependency_Item
30394 Is_Input
: Boolean);
30395 -- Add an item to the proper subprogram input or output collection
30397 -----------------------------
30398 -- Collect_Dependency_Item --
30399 -----------------------------
30401 procedure Collect_Dependency_Item
30403 Is_Input
: Boolean)
30408 -- Nothing to collect when the item is null
30410 if Nkind
(Item
) = N_Null
then
30413 -- Ditto for attribute 'Result
30415 elsif Is_Attribute_Result
(Item
) then
30418 -- Multiple items appear as an aggregate
30420 elsif Nkind
(Item
) = N_Aggregate
then
30421 Extra
:= First
(Expressions
(Item
));
30422 while Present
(Extra
) loop
30423 Collect_Dependency_Item
(Extra
, Is_Input
);
30427 -- Otherwise this is a solitary item
30431 Append_New_Elmt
(Item
, Subp_Inputs
);
30433 Append_New_Elmt
(Item
, Subp_Outputs
);
30436 end Collect_Dependency_Item
;
30438 -- Start of processing for Collect_Dependency_Clause
30441 if Nkind
(Clause
) = N_Null
then
30444 -- A dependency clause appears as component association
30446 elsif Nkind
(Clause
) = N_Component_Association
then
30447 Collect_Dependency_Item
30448 (Item
=> Expression
(Clause
),
30451 Collect_Dependency_Item
30452 (Item
=> First
(Choices
(Clause
)),
30453 Is_Input
=> False);
30455 -- To accommodate partial decoration of disabled SPARK features, this
30456 -- routine may be called with illegal input. If this is the case, do
30457 -- not raise Program_Error.
30462 end Collect_Dependency_Clause
;
30464 -------------------------
30465 -- Collect_Global_List --
30466 -------------------------
30468 procedure Collect_Global_List
30470 Mode
: Name_Id
:= Name_Input
)
30472 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
30473 -- Add an item to the proper subprogram input or output collection
30475 -------------------------
30476 -- Collect_Global_Item --
30477 -------------------------
30479 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
30481 if Mode
in Name_In_Out | Name_Input
then
30482 Append_New_Elmt
(Item
, Subp_Inputs
);
30485 if Mode
in Name_In_Out | Name_Output
then
30486 Append_New_Elmt
(Item
, Subp_Outputs
);
30488 end Collect_Global_Item
;
30495 -- Start of processing for Collect_Global_List
30498 if Nkind
(List
) = N_Null
then
30501 -- Single global item declaration
30503 elsif Nkind
(List
) in N_Expanded_Name
30505 | N_Selected_Component
30507 Collect_Global_Item
(List
, Mode
);
30509 -- Simple global list or moded global list declaration
30511 elsif Nkind
(List
) = N_Aggregate
then
30512 if Present
(Expressions
(List
)) then
30513 Item
:= First
(Expressions
(List
));
30514 while Present
(Item
) loop
30515 Collect_Global_Item
(Item
, Mode
);
30520 Assoc
:= First
(Component_Associations
(List
));
30521 while Present
(Assoc
) loop
30522 Collect_Global_List
30523 (List
=> Expression
(Assoc
),
30524 Mode
=> Chars
(First
(Choices
(Assoc
))));
30529 -- To accommodate partial decoration of disabled SPARK features, this
30530 -- routine may be called with illegal input. If this is the case, do
30531 -- not raise Program_Error.
30536 end Collect_Global_List
;
30543 Formal
: Entity_Id
;
30545 Spec_Id
: Entity_Id
:= Empty
;
30546 Subp_Decl
: Node_Id
;
30549 -- Start of processing for Collect_Subprogram_Inputs_Outputs
30552 Global_Seen
:= False;
30554 -- Process all formal parameters of entries, [generic] subprograms, and
30557 if Ekind
(Subp_Id
) in E_Entry
30560 | E_Generic_Function
30561 | E_Generic_Procedure
30563 | E_Subprogram_Body
30565 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
30566 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30568 -- Process all formal parameters
30570 Formal
:= First_Formal
(Spec_Id
);
30571 while Present
(Formal
) loop
30572 if Ekind
(Formal
) in E_In_Out_Parameter | E_In_Parameter
then
30573 Append_New_Elmt
(Formal
, Subp_Inputs
);
30576 if Ekind
(Formal
) in E_In_Out_Parameter | E_Out_Parameter
then
30577 Append_New_Elmt
(Formal
, Subp_Outputs
);
30579 -- OUT parameters can act as inputs when the related type is
30580 -- tagged, unconstrained array, unconstrained record, or record
30581 -- with unconstrained components.
30583 if Ekind
(Formal
) = E_Out_Parameter
30584 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
30586 Append_New_Elmt
(Formal
, Subp_Inputs
);
30590 -- IN parameters of procedures and protected entries can act as
30591 -- outputs when the related type is access-to-variable.
30593 if Ekind
(Formal
) = E_In_Parameter
30594 and then Ekind
(Spec_Id
) not in E_Function
30595 | E_Generic_Function
30596 and then Is_Access_Variable
(Etype
(Formal
))
30598 Append_New_Elmt
(Formal
, Subp_Outputs
);
30601 Next_Formal
(Formal
);
30604 -- Otherwise the input denotes a task type, a task body, or the
30605 -- anonymous object created for a single task type.
30607 elsif Ekind
(Subp_Id
) in E_Task_Type | E_Task_Body
30608 or else Is_Single_Task_Object
(Subp_Id
)
30610 Subp_Decl
:= Declaration_Node
(Subp_Id
);
30611 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30614 -- When processing an entry, subprogram or task body, look for pragmas
30615 -- Refined_Depends and Refined_Global as they specify the inputs and
30618 if Is_Entry_Body
(Subp_Id
)
30619 or else Ekind
(Subp_Id
) in E_Subprogram_Body | E_Task_Body
30621 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
30622 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
30624 -- Subprogram declaration or stand-alone body case, look for pragmas
30625 -- Depends and Global.
30628 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
30629 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
30632 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30633 -- because it provides finer granularity of inputs and outputs.
30635 if Present
(Global
) then
30636 Global_Seen
:= True;
30637 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
30639 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30640 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30641 -- the inputs and outputs from [Refined_]Depends.
30643 elsif Synthesize
and then Present
(Depends
) then
30644 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
30646 -- Multiple dependency clauses appear as an aggregate
30648 if Nkind
(Clauses
) = N_Aggregate
then
30649 Clause
:= First
(Component_Associations
(Clauses
));
30650 while Present
(Clause
) loop
30651 Collect_Dependency_Clause
(Clause
);
30655 -- Otherwise this is a single dependency clause
30658 Collect_Dependency_Clause
(Clauses
);
30662 -- The current instance of a protected type acts as a formal parameter
30663 -- of mode IN for functions and IN OUT for entries and procedures
30664 -- (SPARK RM 6.1.4).
30666 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
30667 Typ
:= Scope
(Spec_Id
);
30669 -- Use the anonymous object when the type is single protected
30671 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30672 Typ
:= Anonymous_Object
(Typ
);
30675 Append_New_Elmt
(Typ
, Subp_Inputs
);
30677 if Ekind
(Spec_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
30678 Append_New_Elmt
(Typ
, Subp_Outputs
);
30681 -- The current instance of a task type acts as a formal parameter of
30682 -- mode IN OUT (SPARK RM 6.1.4).
30684 elsif Ekind
(Spec_Id
) = E_Task_Type
then
30687 -- Use the anonymous object when the type is single task
30689 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30690 Typ
:= Anonymous_Object
(Typ
);
30693 Append_New_Elmt
(Typ
, Subp_Inputs
);
30694 Append_New_Elmt
(Typ
, Subp_Outputs
);
30696 elsif Is_Single_Task_Object
(Spec_Id
) then
30697 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
30698 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
30700 end Collect_Subprogram_Inputs_Outputs
;
30702 ---------------------------
30703 -- Contract_Freeze_Error --
30704 ---------------------------
30706 procedure Contract_Freeze_Error
30707 (Contract_Id
: Entity_Id
;
30708 Freeze_Id
: Entity_Id
)
30711 Error_Msg_Name_1
:= Chars
(Contract_Id
);
30712 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30715 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
30717 ("\all contractual items must be declared before body #", Contract_Id
);
30718 end Contract_Freeze_Error
;
30720 ---------------------------------
30721 -- Delay_Config_Pragma_Analyze --
30722 ---------------------------------
30724 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
30726 return Pragma_Name_Unmapped
(N
)
30727 in Name_Interrupt_State | Name_Priority_Specific_Dispatching
;
30728 end Delay_Config_Pragma_Analyze
;
30730 -----------------------
30731 -- Duplication_Error --
30732 -----------------------
30734 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
30735 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
30736 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
30739 Error_Msg_Sloc
:= Sloc
(Prev
);
30740 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30742 -- Emit a precise message to distinguish between source pragmas and
30743 -- pragmas generated from aspects. The ordering of the two pragmas is
30747 -- Prag -- duplicate
30749 -- No error is emitted when both pragmas come from aspects because this
30750 -- is already detected by the general aspect analysis mechanism.
30752 if Prag_From_Asp
and Prev_From_Asp
then
30754 elsif Prag_From_Asp
then
30755 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
30756 elsif Prev_From_Asp
then
30757 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
30759 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
30761 end Duplication_Error
;
30763 ------------------------------
30764 -- Find_Encapsulating_State --
30765 ------------------------------
30767 function Find_Encapsulating_State
30768 (States
: Elist_Id
;
30769 Constit_Id
: Entity_Id
) return Entity_Id
30771 State_Id
: Entity_Id
;
30774 -- Since a constituent may be part of a larger constituent set, climb
30775 -- the encapsulating state chain looking for a state that appears in
30778 State_Id
:= Encapsulating_State
(Constit_Id
);
30779 while Present
(State_Id
) loop
30780 if Contains
(States
, State_Id
) then
30784 State_Id
:= Encapsulating_State
(State_Id
);
30788 end Find_Encapsulating_State
;
30790 --------------------------
30791 -- Find_Related_Context --
30792 --------------------------
30794 function Find_Related_Context
30796 Do_Checks
: Boolean := False) return Node_Id
30801 -- If the pragma comes from an aspect on a compilation unit that is a
30802 -- package instance, then return the original package instantiation
30805 if Nkind
(Parent
(Prag
)) = N_Compilation_Unit_Aux
then
30807 Get_Unit_Instantiation_Node
30808 (Defining_Entity
(Unit
(Enclosing_Comp_Unit_Node
(Prag
))));
30811 Stmt
:= Prev
(Prag
);
30812 while Present
(Stmt
) loop
30814 -- Skip prior pragmas, but check for duplicates
30816 if Nkind
(Stmt
) = N_Pragma
then
30818 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
30825 -- Skip internally generated code
30827 elsif not Comes_From_Source
(Stmt
)
30828 and then not Comes_From_Source
(Original_Node
(Stmt
))
30831 -- The anonymous object created for a single concurrent type is a
30832 -- suitable context.
30834 if Nkind
(Stmt
) = N_Object_Declaration
30835 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30840 -- Return the current source construct
30850 end Find_Related_Context
;
30852 --------------------------------------
30853 -- Find_Related_Declaration_Or_Body --
30854 --------------------------------------
30856 function Find_Related_Declaration_Or_Body
30858 Do_Checks
: Boolean := False) return Node_Id
30860 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
30862 procedure Expression_Function_Error
;
30863 -- Emit an error concerning pragma Prag that illegaly applies to an
30864 -- expression function.
30866 -------------------------------
30867 -- Expression_Function_Error --
30868 -------------------------------
30870 procedure Expression_Function_Error
is
30872 Error_Msg_Name_1
:= Prag_Nam
;
30874 -- Emit a precise message to distinguish between source pragmas and
30875 -- pragmas generated from aspects.
30877 if From_Aspect_Specification
(Prag
) then
30879 ("aspect % cannot apply to a standalone expression function",
30883 ("pragma % cannot apply to a standalone expression function",
30886 end Expression_Function_Error
;
30890 Context
: constant Node_Id
:= Parent
(Prag
);
30893 Look_For_Body
: constant Boolean :=
30894 Prag_Nam
in Name_Refined_Depends
30895 | Name_Refined_Global
30896 | Name_Refined_Post
30897 | Name_Refined_State
;
30898 -- Refinement pragmas must be associated with a subprogram body [stub]
30900 -- Start of processing for Find_Related_Declaration_Or_Body
30903 Stmt
:= Prev
(Prag
);
30904 while Present
(Stmt
) loop
30906 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30907 -- by splitting a complex pre/postcondition are not considered to
30910 if Nkind
(Stmt
) = N_Pragma
then
30912 and then not Split_PPC
(Stmt
)
30913 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
30920 -- Emit an error when a refinement pragma appears on an expression
30921 -- function without a completion.
30924 and then Look_For_Body
30925 and then Nkind
(Stmt
) = N_Subprogram_Declaration
30926 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
30927 and then not Has_Completion
(Defining_Entity
(Stmt
))
30929 Expression_Function_Error
;
30932 -- The refinement pragma applies to a subprogram body stub
30934 elsif Look_For_Body
30935 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
30939 -- Skip internally generated code
30941 elsif not Comes_From_Source
(Stmt
) then
30943 -- The anonymous object created for a single concurrent type is a
30944 -- suitable context.
30946 if Nkind
(Stmt
) = N_Object_Declaration
30947 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30951 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
30953 -- The subprogram declaration is an internally generated spec
30954 -- for an expression function.
30956 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30959 -- The subprogram declaration is an internally generated spec
30960 -- for a stand-alone subrogram body declared inside a protected
30963 elsif Present
(Corresponding_Body
(Stmt
))
30964 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
30965 and then Is_Protected_Type
(Current_Scope
)
30969 -- The subprogram is actually an instance housed within an
30970 -- anonymous wrapper package.
30972 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30975 -- Ada 2022: contract on formal subprogram or on generated
30976 -- Access_Subprogram_Wrapper, which appears after the related
30977 -- Access_Subprogram declaration.
30979 elsif Is_Generic_Actual_Subprogram
(Defining_Entity
(Stmt
))
30980 and then Ada_Version
>= Ada_2022
30984 elsif Is_Access_Subprogram_Wrapper
(Defining_Entity
(Stmt
))
30985 and then Ada_Version
>= Ada_2022
30991 -- Return the current construct which is either a subprogram body,
30992 -- a subprogram declaration or is illegal.
31001 -- If we fall through, then the pragma was either the first declaration
31002 -- or it was preceded by other pragmas and no source constructs.
31004 -- The pragma is associated with a library-level subprogram
31006 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
31007 return Unit
(Parent
(Context
));
31009 -- The pragma appears inside the declarations of an entry body
31011 elsif Nkind
(Context
) = N_Entry_Body
then
31014 -- The pragma appears inside the statements of a subprogram body at
31015 -- some nested level.
31017 elsif Is_Statement
(Context
)
31018 and then Present
(Enclosing_HSS
(Context
))
31020 return Parent
(Enclosing_HSS
(Context
));
31022 -- The pragma appears directly in the statements of a subprogram body
31024 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
31025 return Parent
(Context
);
31027 -- The pragma appears inside the declarative part of a package body
31029 elsif Nkind
(Context
) = N_Package_Body
then
31032 -- The pragma appears inside the declarative part of a subprogram body
31034 elsif Nkind
(Context
) = N_Subprogram_Body
then
31037 -- The pragma appears inside the declarative part of a task body
31039 elsif Nkind
(Context
) = N_Task_Body
then
31042 -- The pragma appears inside the visible part of a package specification
31044 elsif Nkind
(Context
) = N_Package_Specification
then
31045 return Parent
(Context
);
31047 -- The pragma is a byproduct of aspect expansion, return the related
31048 -- context of the original aspect. This case has a lower priority as
31049 -- the above circuitry pinpoints precisely the related context.
31051 elsif Present
(Corresponding_Aspect
(Prag
)) then
31052 return Parent
(Corresponding_Aspect
(Prag
));
31054 -- No candidate subprogram [body] found
31059 end Find_Related_Declaration_Or_Body
;
31061 ----------------------------------
31062 -- Find_Related_Package_Or_Body --
31063 ----------------------------------
31065 function Find_Related_Package_Or_Body
31067 Do_Checks
: Boolean := False) return Node_Id
31069 Context
: constant Node_Id
:= Parent
(Prag
);
31070 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
31074 Stmt
:= Prev
(Prag
);
31075 while Present
(Stmt
) loop
31077 -- Skip prior pragmas, but check for duplicates
31079 if Nkind
(Stmt
) = N_Pragma
then
31080 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
31086 -- Skip internally generated code
31088 elsif not Comes_From_Source
(Stmt
) then
31089 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
31091 -- The subprogram declaration is an internally generated spec
31092 -- for an expression function.
31094 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
31097 -- The subprogram is actually an instance housed within an
31098 -- anonymous wrapper package.
31100 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
31105 -- Return the current source construct which is illegal
31114 -- If we fall through, then the pragma was either the first declaration
31115 -- or it was preceded by other pragmas and no source constructs.
31117 -- The pragma is associated with a package. The immediate context in
31118 -- this case is the specification of the package.
31120 if Nkind
(Context
) = N_Package_Specification
then
31121 return Parent
(Context
);
31123 -- The pragma appears in the declarations of a package body
31125 elsif Nkind
(Context
) = N_Package_Body
then
31128 -- The pragma appears in the statements of a package body
31130 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
31131 and then Nkind
(Parent
(Context
)) = N_Package_Body
31133 return Parent
(Context
);
31135 -- The pragma is a byproduct of aspect expansion, return the related
31136 -- context of the original aspect. This case has a lower priority as
31137 -- the above circuitry pinpoints precisely the related context.
31139 elsif Present
(Corresponding_Aspect
(Prag
)) then
31140 return Parent
(Corresponding_Aspect
(Prag
));
31142 -- No candidate package [body] found
31147 end Find_Related_Package_Or_Body
;
31153 function Get_Argument
31155 Context_Id
: Entity_Id
:= Empty
) return Node_Id
31157 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
31160 -- Use the expression of the original aspect when analyzing the template
31161 -- of a generic unit. In both cases the aspect's tree must be decorated
31162 -- to save the global references in the generic context.
31164 if From_Aspect_Specification
(Prag
)
31165 and then (Present
(Context_Id
) and then Is_Generic_Unit
(Context_Id
))
31167 return Corresponding_Aspect
(Prag
);
31169 -- Otherwise use the expression of the pragma
31171 elsif Present
(Args
) then
31172 return First
(Args
);
31179 -------------------------
31180 -- Get_Base_Subprogram --
31181 -------------------------
31183 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
31185 -- Follow subprogram renaming chain
31187 if Is_Subprogram
(Def_Id
)
31188 and then Parent_Kind
(Declaration_Node
(Def_Id
)) =
31189 N_Subprogram_Renaming_Declaration
31190 and then Present
(Alias
(Def_Id
))
31192 return Alias
(Def_Id
);
31196 end Get_Base_Subprogram
;
31198 -----------------------
31199 -- Get_SPARK_Mode_Type --
31200 -----------------------
31202 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
31204 if N
= Name_On
then
31206 elsif N
= Name_Off
then
31209 -- Any other argument is illegal. Assume that no SPARK mode applies to
31210 -- avoid potential cascaded errors.
31215 end Get_SPARK_Mode_Type
;
31217 ------------------------------------
31218 -- Get_SPARK_Mode_From_Annotation --
31219 ------------------------------------
31221 function Get_SPARK_Mode_From_Annotation
31222 (N
: Node_Id
) return SPARK_Mode_Type
31227 if Nkind
(N
) = N_Aspect_Specification
then
31228 Mode
:= Expression
(N
);
31230 else pragma Assert
(Nkind
(N
) = N_Pragma
);
31231 Mode
:= First
(Pragma_Argument_Associations
(N
));
31233 if Present
(Mode
) then
31234 Mode
:= Get_Pragma_Arg
(Mode
);
31238 -- Aspect or pragma SPARK_Mode specifies an explicit mode
31240 if Present
(Mode
) then
31241 if Nkind
(Mode
) = N_Identifier
then
31242 return Get_SPARK_Mode_Type
(Chars
(Mode
));
31244 -- In case of a malformed aspect or pragma, return the default None
31250 -- Otherwise the lack of an expression defaults SPARK_Mode to On
31255 end Get_SPARK_Mode_From_Annotation
;
31257 ---------------------------
31258 -- Has_Extra_Parentheses --
31259 ---------------------------
31261 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
31265 -- The aggregate should not have an expression list because a clause
31266 -- is always interpreted as a component association. The only way an
31267 -- expression list can sneak in is by adding extra parentheses around
31268 -- the individual clauses:
31270 -- Depends (Output => Input) -- proper form
31271 -- Depends ((Output => Input)) -- extra parentheses
31273 -- Since the extra parentheses are not allowed by the syntax of the
31274 -- pragma, flag them now to avoid emitting misleading errors down the
31277 if Nkind
(Clause
) = N_Aggregate
31278 and then Present
(Expressions
(Clause
))
31280 Expr
:= First
(Expressions
(Clause
));
31281 while Present
(Expr
) loop
31283 -- A dependency clause surrounded by extra parentheses appears
31284 -- as an aggregate of component associations with an optional
31285 -- Paren_Count set.
31287 if Nkind
(Expr
) = N_Aggregate
31288 and then Present
(Component_Associations
(Expr
))
31291 ("dependency clause contains extra parentheses", Expr
);
31293 -- Otherwise the expression is a malformed construct
31296 SPARK_Msg_N
("malformed dependency clause", Expr
);
31306 end Has_Extra_Parentheses
;
31312 procedure Initialize
is
31315 Compile_Time_Warnings_Errors
.Init
;
31324 Dummy
:= Dummy
+ 1;
31327 -----------------------------
31328 -- Is_Config_Static_String --
31329 -----------------------------
31331 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
31333 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
31334 -- This is an internal recursive function that is just like the outer
31335 -- function except that it adds the string to the name buffer rather
31336 -- than placing the string in the name buffer.
31338 ------------------------------
31339 -- Add_Config_Static_String --
31340 ------------------------------
31342 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
31349 if Nkind
(N
) = N_Op_Concat
then
31350 if Add_Config_Static_String
(Left_Opnd
(N
)) then
31351 N
:= Right_Opnd
(N
);
31357 if Nkind
(N
) /= N_String_Literal
then
31358 Error_Msg_N
("string literal expected for pragma argument", N
);
31362 for J
in 1 .. String_Length
(Strval
(N
)) loop
31363 C
:= Get_String_Char
(Strval
(N
), J
);
31365 if not In_Character_Range
(C
) then
31367 ("string literal contains invalid wide character",
31368 Sloc
(N
) + 1 + Source_Ptr
(J
));
31372 Add_Char_To_Name_Buffer
(Get_Character
(C
));
31377 end Add_Config_Static_String
;
31379 -- Start of processing for Is_Config_Static_String
31384 return Add_Config_Static_String
(Arg
);
31385 end Is_Config_Static_String
;
31387 -------------------------------
31388 -- Is_Elaboration_SPARK_Mode --
31389 -------------------------------
31391 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
31394 (Nkind
(N
) = N_Pragma
31395 and then Pragma_Name
(N
) = Name_SPARK_Mode
31396 and then Is_List_Member
(N
));
31398 -- Pragma SPARK_Mode affects the elaboration of a package body when it
31399 -- appears in the statement part of the body.
31402 Present
(Parent
(N
))
31403 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
31404 and then List_Containing
(N
) = Statements
(Parent
(N
))
31405 and then Present
(Parent
(Parent
(N
)))
31406 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
31407 end Is_Elaboration_SPARK_Mode
;
31409 -----------------------
31410 -- Is_Enabled_Pragma --
31411 -----------------------
31413 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
31417 if Present
(Prag
) then
31418 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
31420 if Present
(Arg
) then
31421 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
31423 -- The lack of a Boolean argument automatically enables the pragma
31429 -- The pragma is missing, therefore it is not enabled
31434 end Is_Enabled_Pragma
;
31436 -----------------------------------------
31437 -- Is_Non_Significant_Pragma_Reference --
31438 -----------------------------------------
31440 -- This function makes use of the following static table which indicates
31441 -- whether appearance of some name in a given pragma is to be considered
31442 -- as a reference for the purposes of warnings about unreferenced objects.
31444 -- -1 indicates that appearence in any argument is significant
31445 -- 0 indicates that appearance in any argument is not significant
31446 -- +n indicates that appearance as argument n is significant, but all
31447 -- other arguments are not significant
31448 -- 9n arguments from n on are significant, before n insignificant
31450 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
31451 (Pragma_Abort_Defer
=> -1,
31452 Pragma_Abstract_State
=> -1,
31453 Pragma_Ada_83
=> -1,
31454 Pragma_Ada_95
=> -1,
31455 Pragma_Ada_05
=> -1,
31456 Pragma_Ada_2005
=> -1,
31457 Pragma_Ada_12
=> -1,
31458 Pragma_Ada_2012
=> -1,
31459 Pragma_Ada_2022
=> -1,
31460 Pragma_Aggregate_Individually_Assign
=> 0,
31461 Pragma_All_Calls_Remote
=> -1,
31462 Pragma_Allow_Integer_Address
=> -1,
31463 Pragma_Annotate
=> 93,
31464 Pragma_Assert
=> -1,
31465 Pragma_Assert_And_Cut
=> -1,
31466 Pragma_Assertion_Policy
=> 0,
31467 Pragma_Assume
=> -1,
31468 Pragma_Assume_No_Invalid_Values
=> 0,
31469 Pragma_Async_Readers
=> 0,
31470 Pragma_Async_Writers
=> 0,
31471 Pragma_Asynchronous
=> 0,
31472 Pragma_Atomic
=> 0,
31473 Pragma_Atomic_Components
=> 0,
31474 Pragma_Attach_Handler
=> -1,
31475 Pragma_Attribute_Definition
=> 92,
31476 Pragma_Check
=> -1,
31477 Pragma_Check_Float_Overflow
=> 0,
31478 Pragma_Check_Name
=> 0,
31479 Pragma_Check_Policy
=> 0,
31480 Pragma_CPP_Class
=> 0,
31481 Pragma_CPP_Constructor
=> 0,
31482 Pragma_CPP_Virtual
=> 0,
31483 Pragma_CPP_Vtable
=> 0,
31485 Pragma_C_Pass_By_Copy
=> 0,
31486 Pragma_Comment
=> -1,
31487 Pragma_Common_Object
=> 0,
31488 Pragma_CUDA_Device
=> -1,
31489 Pragma_CUDA_Execute
=> -1,
31490 Pragma_CUDA_Global
=> -1,
31491 Pragma_Compile_Time_Error
=> -1,
31492 Pragma_Compile_Time_Warning
=> -1,
31493 Pragma_Compiler_Unit
=> -1,
31494 Pragma_Compiler_Unit_Warning
=> -1,
31495 Pragma_Complete_Representation
=> 0,
31496 Pragma_Complex_Representation
=> 0,
31497 Pragma_Component_Alignment
=> 0,
31498 Pragma_Constant_After_Elaboration
=> 0,
31499 Pragma_Contract_Cases
=> -1,
31500 Pragma_Controlled
=> 0,
31501 Pragma_Convention
=> 0,
31502 Pragma_Convention_Identifier
=> 0,
31503 Pragma_Deadline_Floor
=> -1,
31504 Pragma_Debug
=> -1,
31505 Pragma_Debug_Policy
=> 0,
31506 Pragma_Default_Initial_Condition
=> -1,
31507 Pragma_Default_Scalar_Storage_Order
=> 0,
31508 Pragma_Default_Storage_Pool
=> 0,
31509 Pragma_Depends
=> -1,
31510 Pragma_Detect_Blocking
=> 0,
31511 Pragma_Disable_Atomic_Synchronization
=> 0,
31512 Pragma_Discard_Names
=> 0,
31513 Pragma_Dispatching_Domain
=> -1,
31514 Pragma_Effective_Reads
=> 0,
31515 Pragma_Effective_Writes
=> 0,
31516 Pragma_Elaborate
=> 0,
31517 Pragma_Elaborate_All
=> 0,
31518 Pragma_Elaborate_Body
=> 0,
31519 Pragma_Elaboration_Checks
=> 0,
31520 Pragma_Eliminate
=> 0,
31521 Pragma_Enable_Atomic_Synchronization
=> 0,
31522 Pragma_Export
=> -1,
31523 Pragma_Export_Function
=> -1,
31524 Pragma_Export_Object
=> -1,
31525 Pragma_Export_Procedure
=> -1,
31526 Pragma_Export_Valued_Procedure
=> -1,
31527 Pragma_Extend_System
=> -1,
31528 Pragma_Extensions_Allowed
=> 0,
31529 Pragma_Extensions_Visible
=> 0,
31530 Pragma_External
=> -1,
31531 Pragma_External_Name_Casing
=> 0,
31532 Pragma_Fast_Math
=> 0,
31533 Pragma_Favor_Top_Level
=> 0,
31534 Pragma_Finalize_Storage_Only
=> 0,
31536 Pragma_Global
=> -1,
31537 Pragma_GNAT_Annotate
=> 93,
31538 Pragma_Ident
=> -1,
31539 Pragma_Ignore_Pragma
=> 0,
31540 Pragma_Implementation_Defined
=> -1,
31541 Pragma_Implemented
=> -1,
31542 Pragma_Implicit_Packing
=> 0,
31543 Pragma_Import
=> 93,
31544 Pragma_Import_Function
=> 0,
31545 Pragma_Import_Object
=> 0,
31546 Pragma_Import_Procedure
=> 0,
31547 Pragma_Import_Valued_Procedure
=> 0,
31548 Pragma_Independent
=> 0,
31549 Pragma_Independent_Components
=> 0,
31550 Pragma_Initial_Condition
=> -1,
31551 Pragma_Initialize_Scalars
=> 0,
31552 Pragma_Initializes
=> -1,
31553 Pragma_Inline
=> 0,
31554 Pragma_Inline_Always
=> 0,
31555 Pragma_Inline_Generic
=> 0,
31556 Pragma_Inspection_Point
=> -1,
31557 Pragma_Interface
=> 92,
31558 Pragma_Interface_Name
=> 0,
31559 Pragma_Interrupt_Handler
=> -1,
31560 Pragma_Interrupt_Priority
=> -1,
31561 Pragma_Interrupt_State
=> -1,
31562 Pragma_Invariant
=> -1,
31563 Pragma_Keep_Names
=> 0,
31564 Pragma_License
=> 0,
31565 Pragma_Link_With
=> -1,
31566 Pragma_Linker_Alias
=> -1,
31567 Pragma_Linker_Constructor
=> -1,
31568 Pragma_Linker_Destructor
=> -1,
31569 Pragma_Linker_Options
=> -1,
31570 Pragma_Linker_Section
=> -1,
31572 Pragma_Lock_Free
=> 0,
31573 Pragma_Locking_Policy
=> 0,
31574 Pragma_Loop_Invariant
=> -1,
31575 Pragma_Loop_Optimize
=> 0,
31576 Pragma_Loop_Variant
=> -1,
31577 Pragma_Machine_Attribute
=> -1,
31579 Pragma_Main_Storage
=> -1,
31580 Pragma_Max_Entry_Queue_Depth
=> 0,
31581 Pragma_Max_Entry_Queue_Length
=> 0,
31582 Pragma_Max_Queue_Length
=> 0,
31583 Pragma_Memory_Size
=> 0,
31584 Pragma_No_Body
=> 0,
31585 Pragma_No_Caching
=> 0,
31586 Pragma_No_Component_Reordering
=> -1,
31587 Pragma_No_Elaboration_Code_All
=> 0,
31588 Pragma_No_Heap_Finalization
=> 0,
31589 Pragma_No_Inline
=> 0,
31590 Pragma_No_Return
=> 0,
31591 Pragma_No_Run_Time
=> -1,
31592 Pragma_No_Strict_Aliasing
=> -1,
31593 Pragma_No_Tagged_Streams
=> 0,
31594 Pragma_Normalize_Scalars
=> 0,
31595 Pragma_Obsolescent
=> 0,
31596 Pragma_Optimize
=> 0,
31597 Pragma_Optimize_Alignment
=> 0,
31598 Pragma_Ordered
=> 0,
31599 Pragma_Overflow_Mode
=> 0,
31600 Pragma_Overriding_Renamings
=> 0,
31603 Pragma_Part_Of
=> 0,
31604 Pragma_Partition_Elaboration_Policy
=> 0,
31605 Pragma_Passive
=> 0,
31606 Pragma_Persistent_BSS
=> 0,
31608 Pragma_Postcondition
=> -1,
31609 Pragma_Post_Class
=> -1,
31611 Pragma_Precondition
=> -1,
31612 Pragma_Predicate
=> -1,
31613 Pragma_Predicate_Failure
=> -1,
31614 Pragma_Preelaborable_Initialization
=> -1,
31615 Pragma_Preelaborate
=> 0,
31616 Pragma_Prefix_Exception_Messages
=> 0,
31617 Pragma_Pre_Class
=> -1,
31618 Pragma_Priority
=> -1,
31619 Pragma_Priority_Specific_Dispatching
=> 0,
31620 Pragma_Profile
=> 0,
31621 Pragma_Profile_Warnings
=> 0,
31622 Pragma_Propagate_Exceptions
=> 0,
31623 Pragma_Provide_Shift_Operators
=> 0,
31624 Pragma_Psect_Object
=> 0,
31626 Pragma_Pure_Function
=> 0,
31627 Pragma_Queuing_Policy
=> 0,
31628 Pragma_Rational
=> 0,
31629 Pragma_Ravenscar
=> 0,
31630 Pragma_Refined_Depends
=> -1,
31631 Pragma_Refined_Global
=> -1,
31632 Pragma_Refined_Post
=> -1,
31633 Pragma_Refined_State
=> -1,
31634 Pragma_Relative_Deadline
=> 0,
31635 Pragma_Remote_Access_Type
=> -1,
31636 Pragma_Remote_Call_Interface
=> -1,
31637 Pragma_Remote_Types
=> -1,
31638 Pragma_Rename_Pragma
=> 0,
31639 Pragma_Restricted_Run_Time
=> 0,
31640 Pragma_Restriction_Warnings
=> 0,
31641 Pragma_Restrictions
=> 0,
31642 Pragma_Reviewable
=> -1,
31643 Pragma_Secondary_Stack_Size
=> -1,
31644 Pragma_Share_Generic
=> 0,
31645 Pragma_Shared
=> 0,
31646 Pragma_Shared_Passive
=> 0,
31647 Pragma_Short_Circuit_And_Or
=> 0,
31648 Pragma_Short_Descriptors
=> 0,
31649 Pragma_Simple_Storage_Pool_Type
=> 0,
31650 Pragma_Source_File_Name
=> 0,
31651 Pragma_Source_File_Name_Project
=> 0,
31652 Pragma_Source_Reference
=> 0,
31653 Pragma_SPARK_Mode
=> 0,
31654 Pragma_Static_Elaboration_Desired
=> 0,
31655 Pragma_Storage_Size
=> -1,
31656 Pragma_Storage_Unit
=> 0,
31657 Pragma_Stream_Convert
=> 0,
31658 Pragma_Style_Checks
=> 0,
31659 Pragma_Subprogram_Variant
=> -1,
31660 Pragma_Subtitle
=> 0,
31661 Pragma_Suppress
=> 0,
31662 Pragma_Suppress_All
=> 0,
31663 Pragma_Suppress_Debug_Info
=> 0,
31664 Pragma_Suppress_Exception_Locations
=> 0,
31665 Pragma_Suppress_Initialization
=> 0,
31666 Pragma_System_Name
=> 0,
31667 Pragma_Task_Dispatching_Policy
=> 0,
31668 Pragma_Task_Info
=> -1,
31669 Pragma_Task_Name
=> -1,
31670 Pragma_Task_Storage
=> -1,
31671 Pragma_Test_Case
=> -1,
31672 Pragma_Thread_Local_Storage
=> -1,
31673 Pragma_Time_Slice
=> -1,
31675 Pragma_Type_Invariant
=> -1,
31676 Pragma_Type_Invariant_Class
=> -1,
31677 Pragma_Unchecked_Union
=> 0,
31678 Pragma_Unevaluated_Use_Of_Old
=> 0,
31679 Pragma_Unimplemented_Unit
=> 0,
31680 Pragma_Universal_Aliasing
=> 0,
31681 Pragma_Unmodified
=> 0,
31682 Pragma_Unreferenced
=> 0,
31683 Pragma_Unreferenced_Objects
=> 0,
31684 Pragma_Unreserve_All_Interrupts
=> 0,
31685 Pragma_Unsuppress
=> 0,
31686 Pragma_Unused
=> 0,
31687 Pragma_Use_VADS_Size
=> 0,
31688 Pragma_Validity_Checks
=> 0,
31689 Pragma_Volatile
=> 0,
31690 Pragma_Volatile_Components
=> 0,
31691 Pragma_Volatile_Full_Access
=> 0,
31692 Pragma_Volatile_Function
=> 0,
31693 Pragma_Warning_As_Error
=> 0,
31694 Pragma_Warnings
=> 0,
31695 Pragma_Weak_External
=> 0,
31696 Pragma_Wide_Character_Encoding
=> 0,
31697 Unknown_Pragma
=> 0);
31699 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
31705 function Arg_No
return Nat
;
31706 -- Returns an integer showing what argument we are in. A value of
31707 -- zero means we are not in any of the arguments.
31713 function Arg_No
return Nat
is
31718 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
31732 -- Start of processing for Non_Significant_Pragma_Reference
31737 if Nkind
(P
) /= N_Pragma_Argument_Association
then
31741 Id
:= Get_Pragma_Id
(Parent
(P
));
31742 C
:= Sig_Flags
(Id
);
31757 return AN
< (C
- 90);
31763 end Is_Non_Significant_Pragma_Reference
;
31765 ------------------------------
31766 -- Is_Pragma_String_Literal --
31767 ------------------------------
31769 -- This function returns true if the corresponding pragma argument is a
31770 -- static string expression. These are the only cases in which string
31771 -- literals can appear as pragma arguments. We also allow a string literal
31772 -- as the first argument to pragma Assert (although it will of course
31773 -- always generate a type error).
31775 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
31776 Pragn
: constant Node_Id
:= Parent
(Par
);
31777 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
31778 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
31784 N
:= First
(Assoc
);
31791 if Pname
= Name_Assert
then
31794 elsif Pname
= Name_Export
then
31797 elsif Pname
= Name_Ident
then
31800 elsif Pname
= Name_Import
then
31803 elsif Pname
= Name_Interface_Name
then
31806 elsif Pname
= Name_Linker_Alias
then
31809 elsif Pname
= Name_Linker_Section
then
31812 elsif Pname
= Name_Machine_Attribute
then
31815 elsif Pname
= Name_Source_File_Name
then
31818 elsif Pname
= Name_Source_Reference
then
31821 elsif Pname
= Name_Title
then
31824 elsif Pname
= Name_Subtitle
then
31830 end Is_Pragma_String_Literal
;
31832 ---------------------------
31833 -- Is_Private_SPARK_Mode --
31834 ---------------------------
31836 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
31839 (Nkind
(N
) = N_Pragma
31840 and then Pragma_Name
(N
) = Name_SPARK_Mode
31841 and then Is_List_Member
(N
));
31843 -- For pragma SPARK_Mode to be private, it has to appear in the private
31844 -- declarations of a package.
31847 Present
(Parent
(N
))
31848 and then Nkind
(Parent
(N
)) = N_Package_Specification
31849 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
31850 end Is_Private_SPARK_Mode
;
31852 -------------------------------------
31853 -- Is_Unconstrained_Or_Tagged_Item --
31854 -------------------------------------
31856 function Is_Unconstrained_Or_Tagged_Item
31857 (Item
: Entity_Id
) return Boolean
31859 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
31860 -- Determine whether record type Typ has at least one unconstrained
31863 ---------------------------------
31864 -- Has_Unconstrained_Component --
31865 ---------------------------------
31867 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
31871 Comp
:= First_Component
(Typ
);
31872 while Present
(Comp
) loop
31873 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
31877 Next_Component
(Comp
);
31881 end Has_Unconstrained_Component
;
31885 Typ
: constant Entity_Id
:= Etype
(Item
);
31887 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31890 if Is_Tagged_Type
(Typ
) then
31893 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
31896 elsif Is_Record_Type
(Typ
) then
31897 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
31900 return Has_Unconstrained_Component
(Typ
);
31903 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
31909 end Is_Unconstrained_Or_Tagged_Item
;
31911 -----------------------------
31912 -- Is_Valid_Assertion_Kind --
31913 -----------------------------
31915 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
31922 | Name_Static_Predicate
31923 | Name_Dynamic_Predicate
31928 | Name_Type_Invariant
31929 | Name_uType_Invariant
31933 | Name_Assert_And_Cut
31935 | Name_Contract_Cases
31937 | Name_Default_Initial_Condition
31939 | Name_Initial_Condition
31942 | Name_Loop_Invariant
31943 | Name_Loop_Variant
31944 | Name_Postcondition
31945 | Name_Precondition
31947 | Name_Refined_Post
31948 | Name_Statement_Assertions
31949 | Name_Subprogram_Variant
31956 end Is_Valid_Assertion_Kind
;
31958 --------------------------------------
31959 -- Process_Compilation_Unit_Pragmas --
31960 --------------------------------------
31962 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
31964 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31965 -- strange because it comes at the end of the unit. Rational has the
31966 -- same name for a pragma, but treats it as a program unit pragma, In
31967 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31968 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31969 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31970 -- the context clause to ensure the correct processing.
31972 if Has_Pragma_Suppress_All
(N
) then
31973 Prepend_To
(Context_Items
(N
),
31974 Make_Pragma
(Sloc
(N
),
31975 Chars
=> Name_Suppress
,
31976 Pragma_Argument_Associations
=> New_List
(
31977 Make_Pragma_Argument_Association
(Sloc
(N
),
31978 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
31981 -- Nothing else to do at the current time
31983 end Process_Compilation_Unit_Pragmas
;
31985 --------------------------------------------
31986 -- Validate_Compile_Time_Warning_Or_Error --
31987 --------------------------------------------
31989 procedure Validate_Compile_Time_Warning_Or_Error
31993 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
31994 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
31995 Arg2
: constant Node_Id
:= Next
(Arg1
);
31997 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
31998 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
32001 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
32003 if Compile_Time_Known_Value
(Arg1x
) then
32004 if Is_True
(Expr_Value
(Arg1x
)) then
32006 -- We have already verified that the second argument is a static
32007 -- string expression. Its string value must be retrieved
32008 -- explicitly if it is a declared constant, otherwise it has
32009 -- been constant-folded previously.
32012 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
32013 Str
: constant String_Id
:=
32014 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
32015 Str_Len
: constant Nat
:= String_Length
(Str
);
32017 Force
: constant Boolean :=
32018 Prag_Id
= Pragma_Compile_Time_Warning
32019 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
32020 and then (Ekind
(Cent
) /= E_Package
32021 or else not In_Private_Part
(Cent
));
32022 -- Set True if this is the warning case, and we are in the
32023 -- visible part of a package spec, or in a subprogram spec,
32024 -- in which case we want to force the client to see the
32025 -- warning, even though it is not in the main unit.
32033 -- Loop through segments of message separated by line feeds.
32034 -- We output these segments as separate messages with
32035 -- continuation marks for all but the first.
32040 Error_Msg_Strlen
:= 0;
32042 -- Loop to copy characters from argument to error message
32046 exit when Ptr
> Str_Len
;
32047 CC
:= Get_String_Char
(Str
, Ptr
);
32050 -- Ignore wide chars ??? else store character
32052 if In_Character_Range
(CC
) then
32053 C
:= Get_Character
(CC
);
32054 exit when C
= ASCII
.LF
;
32055 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
32056 Error_Msg_String
(Error_Msg_Strlen
) := C
;
32060 -- Here with one line ready to go
32062 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
32064 -- If this is a warning in a spec, then we want clients
32065 -- to see the warning, so mark the message with the
32066 -- special sequence !! to force the warning. In the case
32067 -- of a package spec, we do not force this if we are in
32068 -- the private part of the spec.
32071 if Cont
= False then
32073 ("<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
32077 ("\<<~!!", Eloc
, Is_Compile_Time_Pragma
=> True);
32080 -- Error, rather than warning, or in a body, so we do not
32081 -- need to force visibility for client (error will be
32082 -- output in any case, and this is the situation in which
32083 -- we do not want a client to get a warning, since the
32084 -- warning is in the body or the spec private part).
32087 if Cont
= False then
32089 ("<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
32093 ("\<<~", Eloc
, Is_Compile_Time_Pragma
=> True);
32097 exit when Ptr
> Str_Len
;
32102 -- Arg1x is not known at compile time, so possibly issue an error
32103 -- or warning. This can happen only if the pragma's processing
32104 -- was deferred until after the back end is run (see
32105 -- Process_Compile_Time_Warning_Or_Error). Note that the warning
32106 -- control switch applies to only the warning case.
32108 elsif Prag_Id
= Pragma_Compile_Time_Error
then
32109 Error_Msg_N
("condition is not known at compile time", Arg1x
);
32111 elsif Warn_On_Unknown_Compile_Time_Warning
then
32112 Error_Msg_N
("?_c?condition is not known at compile time", Arg1x
);
32114 end Validate_Compile_Time_Warning_Or_Error
;
32116 ------------------------------------
32117 -- Record_Possible_Body_Reference --
32118 ------------------------------------
32120 procedure Record_Possible_Body_Reference
32121 (State_Id
: Entity_Id
;
32125 Spec_Id
: Entity_Id
;
32128 -- Ensure that we are dealing with a reference to a state
32130 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
32132 -- Climb the tree starting from the reference looking for a package body
32133 -- whose spec declares the referenced state. This criteria automatically
32134 -- excludes references in package specs which are legal. Note that it is
32135 -- not wise to emit an error now as the package body may lack pragma
32136 -- Refined_State or the referenced state may not be mentioned in the
32137 -- refinement. This approach avoids the generation of misleading errors.
32140 while Present
(Context
) loop
32141 if Nkind
(Context
) = N_Package_Body
then
32142 Spec_Id
:= Corresponding_Spec
(Context
);
32144 if Present
(Abstract_States
(Spec_Id
))
32145 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
32147 if No
(Body_References
(State_Id
)) then
32148 Set_Body_References
(State_Id
, New_Elmt_List
);
32151 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
32156 Context
:= Parent
(Context
);
32158 end Record_Possible_Body_Reference
;
32160 ------------------------------------------
32161 -- Relocate_Pragmas_To_Anonymous_Object --
32162 ------------------------------------------
32164 procedure Relocate_Pragmas_To_Anonymous_Object
32165 (Typ_Decl
: Node_Id
;
32166 Obj_Decl
: Node_Id
)
32170 Next_Decl
: Node_Id
;
32173 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
32174 Def
:= Protected_Definition
(Typ_Decl
);
32176 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
32177 Def
:= Task_Definition
(Typ_Decl
);
32180 -- The concurrent definition has a visible declaration list. Inspect it
32181 -- and relocate all canidate pragmas.
32183 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
32184 Decl
:= First
(Visible_Declarations
(Def
));
32185 while Present
(Decl
) loop
32187 -- Preserve the following declaration for iteration purposes due
32188 -- to possible relocation of a pragma.
32190 Next_Decl
:= Next
(Decl
);
32192 if Nkind
(Decl
) = N_Pragma
32193 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
32196 Insert_After
(Obj_Decl
, Decl
);
32198 -- Skip internally generated code
32200 elsif not Comes_From_Source
(Decl
) then
32203 -- No candidate pragmas are available for relocation
32212 end Relocate_Pragmas_To_Anonymous_Object
;
32214 ------------------------------
32215 -- Relocate_Pragmas_To_Body --
32216 ------------------------------
32218 procedure Relocate_Pragmas_To_Body
32219 (Subp_Body
: Node_Id
;
32220 Target_Body
: Node_Id
:= Empty
)
32222 procedure Relocate_Pragma
(Prag
: Node_Id
);
32223 -- Remove a single pragma from its current list and add it to the
32224 -- declarations of the proper body (either Subp_Body or Target_Body).
32226 ---------------------
32227 -- Relocate_Pragma --
32228 ---------------------
32230 procedure Relocate_Pragma
(Prag
: Node_Id
) is
32235 -- When subprogram stubs or expression functions are involves, the
32236 -- destination declaration list belongs to the proper body.
32238 if Present
(Target_Body
) then
32239 Target
:= Target_Body
;
32241 Target
:= Subp_Body
;
32244 Decls
:= Declarations
(Target
);
32248 Set_Declarations
(Target
, Decls
);
32251 -- Unhook the pragma from its current list
32254 Prepend
(Prag
, Decls
);
32255 end Relocate_Pragma
;
32259 Body_Id
: constant Entity_Id
:=
32260 Defining_Unit_Name
(Specification
(Subp_Body
));
32261 Next_Stmt
: Node_Id
;
32264 -- Start of processing for Relocate_Pragmas_To_Body
32267 -- Do not process a body that comes from a separate unit as no construct
32268 -- can possibly follow it.
32270 if not Is_List_Member
(Subp_Body
) then
32273 -- Do not relocate pragmas that follow a stub if the stub does not have
32276 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
32277 and then No
(Target_Body
)
32281 -- Do not process internally generated routine _Postconditions
32283 elsif Ekind
(Body_Id
) = E_Procedure
32284 and then Chars
(Body_Id
) = Name_uPostconditions
32289 -- Look at what is following the body. We are interested in certain kind
32290 -- of pragmas (either from source or byproducts of expansion) that can
32291 -- apply to a body [stub].
32293 Stmt
:= Next
(Subp_Body
);
32294 while Present
(Stmt
) loop
32296 -- Preserve the following statement for iteration purposes due to a
32297 -- possible relocation of a pragma.
32299 Next_Stmt
:= Next
(Stmt
);
32301 -- Move a candidate pragma following the body to the declarations of
32304 if Nkind
(Stmt
) = N_Pragma
32305 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
32308 -- If a source pragma Warnings follows the body, it applies to
32309 -- following statements and does not belong in the body.
32311 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
32312 and then Comes_From_Source
(Stmt
)
32316 Relocate_Pragma
(Stmt
);
32319 -- Skip internally generated code
32321 elsif not Comes_From_Source
(Stmt
) then
32324 -- No candidate pragmas are available for relocation
32332 end Relocate_Pragmas_To_Body
;
32334 -------------------
32335 -- Resolve_State --
32336 -------------------
32338 procedure Resolve_State
(N
: Node_Id
) is
32343 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
32344 Func
:= Entity
(N
);
32346 -- Handle overloading of state names by functions. Traverse the
32347 -- homonym chain looking for an abstract state.
32349 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
32350 pragma Assert
(Is_Overloaded
(N
));
32352 State
:= Homonym
(Func
);
32353 while Present
(State
) loop
32354 if Ekind
(State
) = E_Abstract_State
then
32356 -- Resolve the overloading by setting the proper entity of
32357 -- the reference to that of the state.
32359 Set_Etype
(N
, Standard_Void_Type
);
32360 Set_Entity
(N
, State
);
32361 Set_Is_Overloaded
(N
, False);
32363 Generate_Reference
(State
, N
);
32367 State
:= Homonym
(State
);
32370 -- A function can never act as a state. If the homonym chain does
32371 -- not contain a corresponding state, then something went wrong in
32372 -- the overloading mechanism.
32374 raise Program_Error
;
32379 ----------------------------
32380 -- Rewrite_Assertion_Kind --
32381 ----------------------------
32383 procedure Rewrite_Assertion_Kind
32385 From_Policy
: Boolean := False)
32391 if Nkind
(N
) = N_Attribute_Reference
32392 and then Attribute_Name
(N
) = Name_Class
32393 and then Nkind
(Prefix
(N
)) = N_Identifier
32395 case Chars
(Prefix
(N
)) is
32402 when Name_Type_Invariant
=>
32403 Nam
:= Name_uType_Invariant
;
32405 when Name_Invariant
=>
32406 Nam
:= Name_uInvariant
;
32412 -- Recommend standard use of aspect names Pre/Post
32414 elsif Nkind
(N
) = N_Identifier
32415 and then From_Policy
32416 and then Serious_Errors_Detected
= 0
32418 if Chars
(N
) = Name_Precondition
32419 or else Chars
(N
) = Name_Postcondition
32421 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
32423 ("\use Assertion_Policy and aspect names Pre/Post for "
32424 & "Ada2012 conformance?", N
);
32430 if Nam
/= No_Name
then
32431 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
32433 end Rewrite_Assertion_Kind
;
32441 Dummy
:= Dummy
+ 1;
32444 --------------------------------
32445 -- Set_Encoded_Interface_Name --
32446 --------------------------------
32448 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
32449 Str
: constant String_Id
:= Strval
(S
);
32450 Len
: constant Nat
:= String_Length
(Str
);
32455 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
32458 -- Stores encoded value of character code CC. The encoding we use an
32459 -- underscore followed by four lower case hex digits.
32465 procedure Encode
is
32467 Store_String_Char
(Get_Char_Code
('_'));
32469 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
32471 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
32473 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
32475 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
32478 -- Start of processing for Set_Encoded_Interface_Name
32481 -- If first character is asterisk, this is a link name, and we leave it
32482 -- completely unmodified. We also ignore null strings (the latter case
32483 -- happens only in error cases).
32486 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
32488 Set_Interface_Name
(E
, S
);
32493 CC
:= Get_String_Char
(Str
, J
);
32495 exit when not In_Character_Range
(CC
);
32497 C
:= Get_Character
(CC
);
32499 exit when C
/= '_' and then C
/= '$'
32500 and then C
not in '0' .. '9'
32501 and then C
not in 'a' .. 'z'
32502 and then C
not in 'A' .. 'Z';
32505 Set_Interface_Name
(E
, S
);
32513 -- Here we need to encode. The encoding we use as follows:
32514 -- three underscores + four hex digits (lower case)
32518 for J
in 1 .. String_Length
(Str
) loop
32519 CC
:= Get_String_Char
(Str
, J
);
32521 if not In_Character_Range
(CC
) then
32524 C
:= Get_Character
(CC
);
32526 if C
= '_' or else C
= '$'
32527 or else C
in '0' .. '9'
32528 or else C
in 'a' .. 'z'
32529 or else C
in 'A' .. 'Z'
32531 Store_String_Char
(CC
);
32538 Set_Interface_Name
(E
,
32539 Make_String_Literal
(Sloc
(S
),
32540 Strval
=> End_String
));
32542 end Set_Encoded_Interface_Name
;
32544 ------------------------
32545 -- Set_Elab_Unit_Name --
32546 ------------------------
32548 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
32553 if Nkind
(N
) = N_Identifier
32554 and then Nkind
(With_Item
) = N_Identifier
32556 Set_Entity
(N
, Entity
(With_Item
));
32558 elsif Nkind
(N
) = N_Selected_Component
then
32559 Change_Selected_Component_To_Expanded_Name
(N
);
32560 Set_Entity
(N
, Entity
(With_Item
));
32561 Set_Entity
(Selector_Name
(N
), Entity
(N
));
32563 Pref
:= Prefix
(N
);
32564 Scop
:= Scope
(Entity
(N
));
32565 while Nkind
(Pref
) = N_Selected_Component
loop
32566 Change_Selected_Component_To_Expanded_Name
(Pref
);
32567 Set_Entity
(Selector_Name
(Pref
), Scop
);
32568 Set_Entity
(Pref
, Scop
);
32569 Pref
:= Prefix
(Pref
);
32570 Scop
:= Scope
(Scop
);
32573 Set_Entity
(Pref
, Scop
);
32576 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
32577 end Set_Elab_Unit_Name
;
32579 -----------------------
32580 -- Set_Overflow_Mode --
32581 -----------------------
32583 procedure Set_Overflow_Mode
(N
: Node_Id
) is
32585 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
;
32586 -- Function to process one pragma argument, Arg
32588 -----------------------
32589 -- Get_Overflow_Mode --
32590 -----------------------
32592 function Get_Overflow_Mode
(Arg
: Node_Id
) return Overflow_Mode_Type
is
32593 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
32596 if Chars
(Argx
) = Name_Strict
then
32599 elsif Chars
(Argx
) = Name_Minimized
then
32602 elsif Chars
(Argx
) = Name_Eliminated
then
32606 raise Program_Error
;
32608 end Get_Overflow_Mode
;
32612 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
32613 Arg2
: constant Node_Id
:= Next
(Arg1
);
32615 -- Start of processing for Set_Overflow_Mode
32618 -- Process first argument
32620 Scope_Suppress
.Overflow_Mode_General
:=
32621 Get_Overflow_Mode
(Arg1
);
32623 -- Case of only one argument
32626 Scope_Suppress
.Overflow_Mode_Assertions
:=
32627 Scope_Suppress
.Overflow_Mode_General
;
32629 -- Case of two arguments present
32632 Scope_Suppress
.Overflow_Mode_Assertions
:=
32633 Get_Overflow_Mode
(Arg2
);
32635 end Set_Overflow_Mode
;
32637 -------------------
32638 -- Test_Case_Arg --
32639 -------------------
32641 function Test_Case_Arg
32644 From_Aspect
: Boolean := False) return Node_Id
32646 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
32652 (Arg_Nam
in Name_Ensures | Name_Mode | Name_Name | Name_Requires
);
32654 -- The caller requests the aspect argument
32656 if From_Aspect
then
32657 if Present
(Aspect
)
32658 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
32660 Args
:= Expression
(Aspect
);
32662 -- "Name" and "Mode" may appear without an identifier as a
32663 -- positional association.
32665 if Present
(Expressions
(Args
)) then
32666 Arg
:= First
(Expressions
(Args
));
32668 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32676 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32681 -- Some or all arguments may appear as component associatons
32683 if Present
(Component_Associations
(Args
)) then
32684 Arg
:= First
(Component_Associations
(Args
));
32685 while Present
(Arg
) loop
32686 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
32695 -- Otherwise retrieve the argument directly from the pragma
32698 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32700 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32704 -- Skip argument "Name"
32708 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32712 -- Skip argument "Mode"
32716 -- Arguments "Requires" and "Ensures" are optional and may not be
32719 while Present
(Arg
) loop
32720 if Chars
(Arg
) = Arg_Nam
then
32731 --------------------------------------------
32732 -- Defer_Compile_Time_Warning_Error_To_BE --
32733 --------------------------------------------
32735 procedure Defer_Compile_Time_Warning_Error_To_BE
(N
: Node_Id
) is
32736 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
32738 Compile_Time_Warnings_Errors
.Append
32739 (New_Val
=> CTWE_Entry
'(Eloc => Sloc (Arg1),
32740 Scope => Current_Scope,
32743 -- If the Boolean expression contains T'Size, and we're not in the main
32744 -- unit being compiled, then we need to copy the pragma into the main
32745 -- unit, because otherwise T'Size might never be computed, leaving it
32748 if not In_Extended_Main_Code_Unit (N) then
32749 Insert_Library_Level_Action (New_Copy_Tree (N));
32751 end Defer_Compile_Time_Warning_Error_To_BE;
32753 ------------------------------------------
32754 -- Validate_Compile_Time_Warning_Errors --
32755 ------------------------------------------
32757 procedure Validate_Compile_Time_Warning_Errors is
32758 procedure Set_Scope (S : Entity_Id);
32759 -- Install all enclosing scopes of S along with S itself
32761 procedure Unset_Scope (S : Entity_Id);
32762 -- Uninstall all enclosing scopes of S along with S itself
32768 procedure Set_Scope (S : Entity_Id) is
32770 if S /= Standard_Standard then
32771 Set_Scope (Scope (S));
32781 procedure Unset_Scope (S : Entity_Id) is
32783 if S /= Standard_Standard then
32784 Unset_Scope (Scope (S));
32790 -- Start of processing for Validate_Compile_Time_Warning_Errors
32793 Expander_Mode_Save_And_Set (False);
32794 In_Compile_Time_Warning_Or_Error := True;
32796 for N in Compile_Time_Warnings_Errors.First ..
32797 Compile_Time_Warnings_Errors.Last
32800 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
32803 Set_Scope (T.Scope);
32804 Reset_Analyzed_Flags (T.Prag);
32805 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
32806 Unset_Scope (T.Scope);
32810 In_Compile_Time_Warning_Or_Error := False;
32811 Expander_Mode_Restore;
32812 end Validate_Compile_Time_Warning_Errors;