1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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 Elists
; use Elists
;
41 with Errout
; use Errout
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
46 with Gnatvsn
; use Gnatvsn
;
48 with Lib
.Writ
; use Lib
.Writ
;
49 with Lib
.Xref
; use Lib
.Xref
;
50 with Namet
.Sp
; use Namet
.Sp
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
53 with Output
; use Output
;
54 with Par_SCO
; use Par_SCO
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch6
; use Sem_Ch6
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Ch12
; use Sem_Ch12
;
64 with Sem_Ch13
; use Sem_Ch13
;
65 with Sem_Disp
; use Sem_Disp
;
66 with Sem_Dist
; use Sem_Dist
;
67 with Sem_Elab
; use Sem_Elab
;
68 with Sem_Elim
; use Sem_Elim
;
69 with Sem_Eval
; use Sem_Eval
;
70 with Sem_Intr
; use Sem_Intr
;
71 with Sem_Mech
; use Sem_Mech
;
72 with Sem_Res
; use Sem_Res
;
73 with Sem_Type
; use Sem_Type
;
74 with Sem_Util
; use Sem_Util
;
75 with Sem_Warn
; use Sem_Warn
;
76 with Stand
; use Stand
;
77 with Sinfo
; use Sinfo
;
78 with Sinfo
.CN
; use Sinfo
.CN
;
79 with Sinput
; use Sinput
;
80 with Stringt
; use Stringt
;
81 with Stylesw
; use Stylesw
;
83 with Targparm
; use Targparm
;
84 with Tbuild
; use Tbuild
;
86 with Uintp
; use Uintp
;
87 with Uname
; use Uname
;
88 with Urealp
; use Urealp
;
89 with Validsw
; use Validsw
;
90 with Warnsw
; use Warnsw
;
92 with System
.Case_Util
;
94 package body Sem_Prag
is
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
114 -- EXTERNAL_SYMBOL ::=
116 -- | static_string_EXPRESSION
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
161 package Externals
is new Table
.Table
(
162 Table_Component_Type
=> Node_Id
,
163 Table_Index_Type
=> Int
,
164 Table_Low_Bound
=> 0,
165 Table_Initial
=> 100,
166 Table_Increment
=> 100,
167 Table_Name
=> "Name_Externals");
169 -------------------------------------
170 -- Local Subprograms and Variables --
171 -------------------------------------
173 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 procedure Analyze_Part_Of
185 Encap_Id
: out Entity_Id
;
186 Legal
: out Boolean);
187 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
188 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
189 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
190 -- package instantiation. Encap denotes the encapsulating state or single
191 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
192 -- the indicator is legal.
194 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
195 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
196 -- Query whether a particular item appears in a mixed list of nodes and
197 -- entities. It is assumed that all nodes in the list have entities.
199 procedure Check_Postcondition_Use_In_Inlined_Subprogram
201 Spec_Id
: Entity_Id
);
202 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
203 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
204 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
205 -- and assertions are enabled.
207 procedure Check_State_And_Constituent_Use
211 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
212 -- Global and Initializes. Determine whether a state from list States and a
213 -- corresponding constituent from list Constits (if any) appear in the same
214 -- context denoted by Context. If this is the case, emit an error.
216 procedure Contract_Freeze_Error
217 (Contract_Id
: Entity_Id
;
218 Freeze_Id
: Entity_Id
);
219 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
220 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
221 -- of a body which caused contract freezing and Contract_Id denotes the
222 -- entity of the affected contstruct.
224 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
225 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
226 -- Prag that duplicates previous pragma Prev.
228 function Find_Encapsulating_State
230 Constit_Id
: Entity_Id
) return Entity_Id
;
231 -- Given the entity of a constituent Constit_Id, find the corresponding
232 -- encapsulating state which appears in States. The routine returns Empty
233 -- if no such state is found.
235 function Find_Related_Context
237 Do_Checks
: Boolean := False) return Node_Id
;
238 -- Subsidiary to the analysis of pragmas
241 -- Constant_After_Elaboration
245 -- Find the first source declaration or statement found while traversing
246 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
247 -- set, the routine reports duplicate pragmas. The routine returns Empty
248 -- when reaching the start of the node chain.
250 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
251 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
252 -- original one, following the renaming chain) is returned. Otherwise the
253 -- entity is returned unchanged. Should be in Einfo???
255 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
256 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
257 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
258 -- value of type SPARK_Mode_Type.
260 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
261 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
262 -- Determine whether dependency clause Clause is surrounded by extra
263 -- parentheses. If this is the case, issue an error message.
265 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
266 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
267 -- pragma Depends. Determine whether the type of dependency item Item is
268 -- tagged, unconstrained array, unconstrained record or a record with at
269 -- least one unconstrained component.
271 procedure Record_Possible_Body_Reference
272 (State_Id
: Entity_Id
;
274 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
275 -- Global. Given an abstract state denoted by State_Id and a reference Ref
276 -- to it, determine whether the reference appears in a package body that
277 -- will eventually refine the state. If this is the case, record the
278 -- reference for future checks (see Analyze_Refined_State_In_Decls).
280 procedure Resolve_State
(N
: Node_Id
);
281 -- Handle the overloading of state names by functions. When N denotes a
282 -- function, this routine finds the corresponding state and sets the entity
283 -- of N to that of the state.
285 procedure Rewrite_Assertion_Kind
287 From_Policy
: Boolean := False);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
291 -- and Check_Policy. If the names are Precondition or Postcondition, this
292 -- combination is deprecated in favor of Assertion_Policy and Ada2012
293 -- Aspect names. The parameter From_Policy indicates that the pragma
294 -- is the old non-standard Check_Policy and not a rewritten pragma.
296 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
297 -- Place semantic information on the argument of an Elaborate/Elaborate_All
298 -- pragma. Entity name for unit and its parents is taken from item in
299 -- previous with_clause that mentions the unit.
301 Dummy
: Integer := 0;
302 pragma Volatile
(Dummy
);
303 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
306 pragma No_Inline
(ip
);
307 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
308 -- is just to help debugging the front end. If a pragma Inspection_Point
309 -- is added to a source program, then breaking on ip will get you to that
310 -- point in the program.
313 pragma No_Inline
(rv
);
314 -- This is a dummy function called by the processing for pragma Reviewable.
315 -- It is there for assisting front end debugging. By placing a Reviewable
316 -- pragma in the source program, a breakpoint on rv catches this place in
317 -- the source, allowing convenient stepping to the point of interest.
319 -------------------------------
320 -- Adjust_External_Name_Case --
321 -------------------------------
323 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
327 -- Adjust case of literal if required
329 if Opt
.External_Name_Exp_Casing
= As_Is
then
333 -- Copy existing string
339 for J
in 1 .. String_Length
(Strval
(N
)) loop
340 CC
:= Get_String_Char
(Strval
(N
), J
);
342 if Opt
.External_Name_Exp_Casing
= Uppercase
343 and then CC
>= Get_Char_Code
('a')
344 and then CC
<= Get_Char_Code
('z')
346 Store_String_Char
(CC
- 32);
348 elsif Opt
.External_Name_Exp_Casing
= Lowercase
349 and then CC
>= Get_Char_Code
('A')
350 and then CC
<= Get_Char_Code
('Z')
352 Store_String_Char
(CC
+ 32);
355 Store_String_Char
(CC
);
360 Make_String_Literal
(Sloc
(N
),
361 Strval
=> End_String
);
363 end Adjust_External_Name_Case
;
365 -----------------------------------------
366 -- Analyze_Contract_Cases_In_Decl_Part --
367 -----------------------------------------
369 -- WARNING: This routine manages Ghost regions. Return statements must be
370 -- replaced by gotos which jump to the end of the routine and restore the
373 procedure Analyze_Contract_Cases_In_Decl_Part
375 Freeze_Id
: Entity_Id
:= Empty
)
377 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
378 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
380 Others_Seen
: Boolean := False;
381 -- This flag is set when an "others" choice is encountered. It is used
382 -- to detect multiple illegal occurrences of "others".
384 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
385 -- Verify the legality of a single contract case
387 ---------------------------
388 -- Analyze_Contract_Case --
389 ---------------------------
391 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
392 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Errors
:= Serious_Errors_Detected
;
432 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 -- Emit a clarification message when the case guard contains
435 -- at least one undefined reference, possibly due to contract
438 if Errors
/= Serious_Errors_Detected
439 and then Present
(Freeze_Id
)
440 and then Has_Undefined_Reference
(Case_Guard
)
442 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
446 Errors
:= Serious_Errors_Detected
;
447 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
449 -- Emit a clarification message when the consequence contains
450 -- at least one undefined reference, possibly due to contract
453 if Errors
/= Serious_Errors_Detected
454 and then Present
(Freeze_Id
)
455 and then Has_Undefined_Reference
(Conseq
)
457 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
460 -- The contract case is malformed
463 Error_Msg_N
("wrong syntax in contract case", CCase
);
465 end Analyze_Contract_Case
;
469 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
471 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
472 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
473 -- Save the Ghost-related attributes to restore on exit
476 Restore_Scope
: Boolean := False;
478 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
481 -- Do not analyze the pragma multiple times
483 if Is_Analyzed_Pragma
(N
) then
487 -- Set the Ghost mode in effect from the pragma. Due to the delayed
488 -- analysis of the pragma, the Ghost mode at point of declaration and
489 -- point of analysis may not necessarily be the same. Use the mode in
490 -- effect at the point of declaration.
494 -- Single and multiple contract cases must appear in aggregate form. If
495 -- this is not the case, then either the parser of the analysis of the
496 -- pragma failed to produce an aggregate.
498 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
500 if Present
(Component_Associations
(CCases
)) then
502 -- Ensure that the formal parameters are visible when analyzing all
503 -- clauses. This falls out of the general rule of aspects pertaining
504 -- to subprogram declarations.
506 if not In_Open_Scopes
(Spec_Id
) then
507 Restore_Scope
:= True;
508 Push_Scope
(Spec_Id
);
510 if Is_Generic_Subprogram
(Spec_Id
) then
511 Install_Generic_Formals
(Spec_Id
);
513 Install_Formals
(Spec_Id
);
517 CCase
:= First
(Component_Associations
(CCases
));
518 while Present
(CCase
) loop
519 Analyze_Contract_Case
(CCase
);
523 if Restore_Scope
then
527 -- Currently it is not possible to inline pre/postconditions on a
528 -- subprogram subject to pragma Inline_Always.
530 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
532 -- Otherwise the pragma is illegal
535 Error_Msg_N
("wrong syntax for constract cases", N
);
538 Set_Is_Analyzed_Pragma
(N
);
540 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
541 end Analyze_Contract_Cases_In_Decl_Part
;
543 ----------------------------------
544 -- Analyze_Depends_In_Decl_Part --
545 ----------------------------------
547 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
548 Loc
: constant Source_Ptr
:= Sloc
(N
);
549 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
550 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
552 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
553 -- A list containing the entities of all the inputs processed so far.
554 -- The list is populated with unique entities because the same input
555 -- may appear in multiple input lists.
557 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
558 -- A list containing the entities of all the outputs processed so far.
559 -- The list is populated with unique entities because output items are
560 -- unique in a dependence relation.
562 Constits_Seen
: Elist_Id
:= No_Elist
;
563 -- A list containing the entities of all constituents processed so far.
564 -- It aids in detecting illegal usage of a state and a corresponding
565 -- constituent in pragma [Refinde_]Depends.
567 Global_Seen
: Boolean := False;
568 -- A flag set when pragma Global has been processed
570 Null_Output_Seen
: Boolean := False;
571 -- A flag used to track the legality of a null output
573 Result_Seen
: Boolean := False;
574 -- A flag set when Spec_Id'Result is processed
576 States_Seen
: Elist_Id
:= No_Elist
;
577 -- A list containing the entities of all states processed so far. It
578 -- helps in detecting illegal usage of a state and a corresponding
579 -- constituent in pragma [Refined_]Depends.
581 Subp_Inputs
: Elist_Id
:= No_Elist
;
582 Subp_Outputs
: Elist_Id
:= No_Elist
;
583 -- Two lists containing the full set of inputs and output of the related
584 -- subprograms. Note that these lists contain both nodes and entities.
586 Task_Input_Seen
: Boolean := False;
587 Task_Output_Seen
: Boolean := False;
588 -- Flags used to track the implicit dependence of a task unit on itself
590 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
591 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
592 -- to the name buffer. The individual kinds are as follows:
593 -- E_Abstract_State - "state"
594 -- E_Constant - "constant"
595 -- E_Generic_In_Out_Parameter - "generic parameter"
596 -- E_Generic_In_Parameter - "generic parameter"
597 -- E_In_Parameter - "parameter"
598 -- E_In_Out_Parameter - "parameter"
599 -- E_Loop_Parameter - "loop parameter"
600 -- E_Out_Parameter - "parameter"
601 -- E_Protected_Type - "current instance of protected type"
602 -- E_Task_Type - "current instance of task type"
603 -- E_Variable - "global"
605 procedure Analyze_Dependency_Clause
608 -- Verify the legality of a single dependency clause. Flag Is_Last
609 -- denotes whether Clause is the last clause in the relation.
611 procedure Check_Function_Return
;
612 -- Verify that Funtion'Result appears as one of the outputs
613 -- (SPARK RM 6.1.5(10)).
620 -- Ensure that an item fulfills its designated input and/or output role
621 -- as specified by pragma Global (if any) or the enclosing context. If
622 -- this is not the case, emit an error. Item and Item_Id denote the
623 -- attributes of an item. Flag Is_Input should be set when item comes
624 -- from an input list. Flag Self_Ref should be set when the item is an
625 -- output and the dependency clause has operator "+".
627 procedure Check_Usage
628 (Subp_Items
: Elist_Id
;
629 Used_Items
: Elist_Id
;
631 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
632 -- error if this is not the case.
634 procedure Normalize_Clause
(Clause
: Node_Id
);
635 -- Remove a self-dependency "+" from the input list of a clause
637 -----------------------------
638 -- Add_Item_To_Name_Buffer --
639 -----------------------------
641 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
643 if Ekind
(Item_Id
) = E_Abstract_State
then
644 Add_Str_To_Name_Buffer
("state");
646 elsif Ekind
(Item_Id
) = E_Constant
then
647 Add_Str_To_Name_Buffer
("constant");
649 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
650 E_Generic_In_Parameter
)
652 Add_Str_To_Name_Buffer
("generic parameter");
654 elsif Is_Formal
(Item_Id
) then
655 Add_Str_To_Name_Buffer
("parameter");
657 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
658 Add_Str_To_Name_Buffer
("loop parameter");
660 elsif Ekind
(Item_Id
) = E_Protected_Type
661 or else Is_Single_Protected_Object
(Item_Id
)
663 Add_Str_To_Name_Buffer
("current instance of protected type");
665 elsif Ekind
(Item_Id
) = E_Task_Type
666 or else Is_Single_Task_Object
(Item_Id
)
668 Add_Str_To_Name_Buffer
("current instance of task type");
670 elsif Ekind
(Item_Id
) = E_Variable
then
671 Add_Str_To_Name_Buffer
("global");
673 -- The routine should not be called with non-SPARK items
678 end Add_Item_To_Name_Buffer
;
680 -------------------------------
681 -- Analyze_Dependency_Clause --
682 -------------------------------
684 procedure Analyze_Dependency_Clause
688 procedure Analyze_Input_List
(Inputs
: Node_Id
);
689 -- Verify the legality of a single input list
691 procedure Analyze_Input_Output
696 Seen
: in out Elist_Id
;
697 Null_Seen
: in out Boolean;
698 Non_Null_Seen
: in out Boolean);
699 -- Verify the legality of a single input or output item. Flag
700 -- Is_Input should be set whenever Item is an input, False when it
701 -- denotes an output. Flag Self_Ref should be set when the item is an
702 -- output and the dependency clause has a "+". Flag Top_Level should
703 -- be set whenever Item appears immediately within an input or output
704 -- list. Seen is a collection of all abstract states, objects and
705 -- formals processed so far. Flag Null_Seen denotes whether a null
706 -- input or output has been encountered. Flag Non_Null_Seen denotes
707 -- whether a non-null input or output has been encountered.
709 ------------------------
710 -- Analyze_Input_List --
711 ------------------------
713 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
714 Inputs_Seen
: Elist_Id
:= No_Elist
;
715 -- A list containing the entities of all inputs that appear in the
716 -- current input list.
718 Non_Null_Input_Seen
: Boolean := False;
719 Null_Input_Seen
: Boolean := False;
720 -- Flags used to check the legality of an input list
725 -- Multiple inputs appear as an aggregate
727 if Nkind
(Inputs
) = N_Aggregate
then
728 if Present
(Component_Associations
(Inputs
)) then
730 ("nested dependency relations not allowed", Inputs
);
732 elsif Present
(Expressions
(Inputs
)) then
733 Input
:= First
(Expressions
(Inputs
));
734 while Present
(Input
) loop
741 Null_Seen
=> Null_Input_Seen
,
742 Non_Null_Seen
=> Non_Null_Input_Seen
);
747 -- Syntax error, always report
750 Error_Msg_N
("malformed input dependency list", Inputs
);
753 -- Process a solitary input
762 Null_Seen
=> Null_Input_Seen
,
763 Non_Null_Seen
=> Non_Null_Input_Seen
);
766 -- Detect an illegal dependency clause of the form
770 if Null_Output_Seen
and then Null_Input_Seen
then
772 ("null dependency clause cannot have a null input list",
775 end Analyze_Input_List
;
777 --------------------------
778 -- Analyze_Input_Output --
779 --------------------------
781 procedure Analyze_Input_Output
786 Seen
: in out Elist_Id
;
787 Null_Seen
: in out Boolean;
788 Non_Null_Seen
: in out Boolean)
790 procedure Current_Task_Instance_Seen
;
791 -- Set the appropriate global flag when the current instance of a
792 -- task unit is encountered.
794 --------------------------------
795 -- Current_Task_Instance_Seen --
796 --------------------------------
798 procedure Current_Task_Instance_Seen
is
801 Task_Input_Seen
:= True;
803 Task_Output_Seen
:= True;
805 end Current_Task_Instance_Seen
;
809 Is_Output
: constant Boolean := not Is_Input
;
813 -- Start of processing for Analyze_Input_Output
816 -- Multiple input or output items appear as an aggregate
818 if Nkind
(Item
) = N_Aggregate
then
819 if not Top_Level
then
820 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
822 elsif Present
(Component_Associations
(Item
)) then
824 ("nested dependency relations not allowed", Item
);
826 -- Recursively analyze the grouped items
828 elsif Present
(Expressions
(Item
)) then
829 Grouped
:= First
(Expressions
(Item
));
830 while Present
(Grouped
) loop
833 Is_Input
=> Is_Input
,
834 Self_Ref
=> Self_Ref
,
837 Null_Seen
=> Null_Seen
,
838 Non_Null_Seen
=> Non_Null_Seen
);
843 -- Syntax error, always report
846 Error_Msg_N
("malformed dependency list", Item
);
849 -- Process attribute 'Result in the context of a dependency clause
851 elsif Is_Attribute_Result
(Item
) then
852 Non_Null_Seen
:= True;
856 -- Attribute 'Result is allowed to appear on the output side of
857 -- a dependency clause (SPARK RM 6.1.5(6)).
860 SPARK_Msg_N
("function result cannot act as input", Item
);
864 ("cannot mix null and non-null dependency items", Item
);
870 -- Detect multiple uses of null in a single dependency list or
871 -- throughout the whole relation. Verify the placement of a null
872 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
874 elsif Nkind
(Item
) = N_Null
then
877 ("multiple null dependency relations not allowed", Item
);
879 elsif Non_Null_Seen
then
881 ("cannot mix null and non-null dependency items", Item
);
889 ("null output list must be the last clause in a "
890 & "dependency relation", Item
);
892 -- Catch a useless dependence of the form:
897 ("useless dependence, null depends on itself", Item
);
905 Non_Null_Seen
:= True;
908 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
912 Resolve_State
(Item
);
914 -- Find the entity of the item. If this is a renaming, climb
915 -- the renaming chain to reach the root object. Renamings of
916 -- non-entire objects do not yield an entity (Empty).
918 Item_Id
:= Entity_Of
(Item
);
920 if Present
(Item_Id
) then
924 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
927 -- Current instances of concurrent types
929 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
934 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
935 E_Generic_In_Parameter
,
943 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
945 -- A [generic] function is not allowed to have Output
946 -- items in its dependency relations. Note that "null"
947 -- and attribute 'Result are still valid items.
949 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
950 and then not Is_Input
953 ("output item is not applicable to function", Item
);
956 -- The item denotes a concurrent type. Note that single
957 -- protected/task types are not considered here because
958 -- they behave as objects in the context of pragma
959 -- [Refined_]Depends.
961 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
963 -- This use is legal as long as the concurrent type is
964 -- the current instance of an enclosing type.
966 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
968 -- The dependence of a task unit on itself is
969 -- implicit and may or may not be explicitly
970 -- specified (SPARK RM 6.1.4).
972 if Ekind
(Item_Id
) = E_Task_Type
then
973 Current_Task_Instance_Seen
;
976 -- Otherwise this is not the current instance
980 ("invalid use of subtype mark in dependency "
984 -- The dependency of a task unit on itself is implicit
985 -- and may or may not be explicitly specified
988 elsif Is_Single_Task_Object
(Item_Id
)
989 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
991 Current_Task_Instance_Seen
;
994 -- Ensure that the item fulfills its role as input and/or
995 -- output as specified by pragma Global or the enclosing
998 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1000 -- Detect multiple uses of the same state, variable or
1001 -- formal parameter. If this is not the case, add the
1002 -- item to the list of processed relations.
1004 if Contains
(Seen
, Item_Id
) then
1006 ("duplicate use of item &", Item
, Item_Id
);
1008 Append_New_Elmt
(Item_Id
, Seen
);
1011 -- Detect illegal use of an input related to a null
1012 -- output. Such input items cannot appear in other
1013 -- input lists (SPARK RM 6.1.5(13)).
1016 and then Null_Output_Seen
1017 and then Contains
(All_Inputs_Seen
, Item_Id
)
1020 ("input of a null output list cannot appear in "
1021 & "multiple input lists", Item
);
1024 -- Add an input or a self-referential output to the list
1025 -- of all processed inputs.
1027 if Is_Input
or else Self_Ref
then
1028 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1031 -- State related checks (SPARK RM 6.1.5(3))
1033 if Ekind
(Item_Id
) = E_Abstract_State
then
1035 -- Package and subprogram bodies are instantiated
1036 -- individually in a separate compiler pass. Due to
1037 -- this mode of instantiation, the refinement of a
1038 -- state may no longer be visible when a subprogram
1039 -- body contract is instantiated. Since the generic
1040 -- template is legal, do not perform this check in
1041 -- the instance to circumvent this oddity.
1043 if Is_Generic_Instance
(Spec_Id
) then
1046 -- An abstract state with visible refinement cannot
1047 -- appear in pragma [Refined_]Depends as its place
1048 -- must be taken by some of its constituents
1049 -- (SPARK RM 6.1.4(7)).
1051 elsif Has_Visible_Refinement
(Item_Id
) then
1053 ("cannot mention state & in dependence relation",
1055 SPARK_Msg_N
("\use its constituents instead", Item
);
1058 -- If the reference to the abstract state appears in
1059 -- an enclosing package body that will eventually
1060 -- refine the state, record the reference for future
1064 Record_Possible_Body_Reference
1065 (State_Id
=> Item_Id
,
1070 -- When the item renames an entire object, replace the
1071 -- item with a reference to the object.
1073 if Entity
(Item
) /= Item_Id
then
1075 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1079 -- Add the entity of the current item to the list of
1082 if Ekind
(Item_Id
) = E_Abstract_State
then
1083 Append_New_Elmt
(Item_Id
, States_Seen
);
1085 -- The variable may eventually become a constituent of a
1086 -- single protected/task type. Record the reference now
1087 -- and verify its legality when analyzing the contract of
1088 -- the variable (SPARK RM 9.3).
1090 elsif Ekind
(Item_Id
) = E_Variable
then
1091 Record_Possible_Part_Of_Reference
1096 if Ekind_In
(Item_Id
, E_Abstract_State
,
1099 and then Present
(Encapsulating_State
(Item_Id
))
1101 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1104 -- All other input/output items are illegal
1105 -- (SPARK RM 6.1.5(1)).
1109 ("item must denote parameter, variable, state or "
1110 & "current instance of concurrent type", Item
);
1113 -- All other input/output items are illegal
1114 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1118 ("item must denote parameter, variable, state or current "
1119 & "instance of concurrent type", Item
);
1122 end Analyze_Input_Output
;
1130 Non_Null_Output_Seen
: Boolean := False;
1131 -- Flag used to check the legality of an output list
1133 -- Start of processing for Analyze_Dependency_Clause
1136 Inputs
:= Expression
(Clause
);
1139 -- An input list with a self-dependency appears as operator "+" where
1140 -- the actuals inputs are the right operand.
1142 if Nkind
(Inputs
) = N_Op_Plus
then
1143 Inputs
:= Right_Opnd
(Inputs
);
1147 -- Process the output_list of a dependency_clause
1149 Output
:= First
(Choices
(Clause
));
1150 while Present
(Output
) loop
1151 Analyze_Input_Output
1154 Self_Ref
=> Self_Ref
,
1156 Seen
=> All_Outputs_Seen
,
1157 Null_Seen
=> Null_Output_Seen
,
1158 Non_Null_Seen
=> Non_Null_Output_Seen
);
1163 -- Process the input_list of a dependency_clause
1165 Analyze_Input_List
(Inputs
);
1166 end Analyze_Dependency_Clause
;
1168 ---------------------------
1169 -- Check_Function_Return --
1170 ---------------------------
1172 procedure Check_Function_Return
is
1174 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1175 and then not Result_Seen
1178 ("result of & must appear in exactly one output list",
1181 end Check_Function_Return
;
1187 procedure Check_Role
1189 Item_Id
: Entity_Id
;
1194 (Item_Is_Input
: out Boolean;
1195 Item_Is_Output
: out Boolean);
1196 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1197 -- Item_Is_Output are set depending on the role.
1199 procedure Role_Error
1200 (Item_Is_Input
: Boolean;
1201 Item_Is_Output
: Boolean);
1202 -- Emit an error message concerning the incorrect use of Item in
1203 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1204 -- denote whether the item is an input and/or an output.
1211 (Item_Is_Input
: out Boolean;
1212 Item_Is_Output
: out Boolean)
1215 case Ekind
(Item_Id
) is
1219 when E_Abstract_State
=>
1221 -- When pragma Global is present it determines the mode of
1222 -- the abstract state.
1225 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1226 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1228 -- Otherwise the state has a default IN OUT mode, because it
1229 -- behaves as a variable.
1232 Item_Is_Input
:= True;
1233 Item_Is_Output
:= True;
1236 -- Constants and IN parameters
1239 | E_Generic_In_Parameter
1243 -- When pragma Global is present it determines the mode
1244 -- of constant objects as inputs (and such objects cannot
1245 -- appear as outputs in the Global contract).
1248 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1250 Item_Is_Input
:= True;
1253 Item_Is_Output
:= False;
1255 -- Variables and IN OUT parameters
1257 when E_Generic_In_Out_Parameter
1258 | E_In_Out_Parameter
1261 -- When pragma Global is present it determines the mode of
1266 -- A variable has mode IN when its type is unconstrained
1267 -- or tagged because array bounds, discriminants or tags
1271 Appears_In
(Subp_Inputs
, Item_Id
)
1272 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1274 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1276 -- Otherwise the variable has a default IN OUT mode
1279 Item_Is_Input
:= True;
1280 Item_Is_Output
:= True;
1283 when E_Out_Parameter
=>
1285 -- An OUT parameter of the related subprogram; it cannot
1286 -- appear in Global.
1288 if Scope
(Item_Id
) = Spec_Id
then
1290 -- The parameter has mode IN if its type is unconstrained
1291 -- or tagged because array bounds, discriminants or tags
1295 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1297 Item_Is_Output
:= True;
1299 -- An OUT parameter of an enclosing subprogram; it can
1300 -- appear in Global and behaves as a read-write variable.
1303 -- When pragma Global is present it determines the mode
1308 -- A variable has mode IN when its type is
1309 -- unconstrained or tagged because array
1310 -- bounds, discriminants or tags can be read.
1313 Appears_In
(Subp_Inputs
, Item_Id
)
1314 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1316 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1318 -- Otherwise the variable has a default IN OUT mode
1321 Item_Is_Input
:= True;
1322 Item_Is_Output
:= True;
1328 when E_Protected_Type
=>
1331 -- A variable has mode IN when its type is unconstrained
1332 -- or tagged because array bounds, discriminants or tags
1336 Appears_In
(Subp_Inputs
, Item_Id
)
1337 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1339 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1342 -- A protected type acts as a formal parameter of mode IN
1343 -- when it applies to a protected function.
1345 if Ekind
(Spec_Id
) = E_Function
then
1346 Item_Is_Input
:= True;
1347 Item_Is_Output
:= False;
1349 -- Otherwise the protected type acts as a formal of mode
1353 Item_Is_Input
:= True;
1354 Item_Is_Output
:= True;
1362 -- When pragma Global is present it determines the mode of
1367 Appears_In
(Subp_Inputs
, Item_Id
)
1368 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1370 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1372 -- Otherwise task types act as IN OUT parameters
1375 Item_Is_Input
:= True;
1376 Item_Is_Output
:= True;
1380 raise Program_Error
;
1388 procedure Role_Error
1389 (Item_Is_Input
: Boolean;
1390 Item_Is_Output
: Boolean)
1392 Error_Msg
: Name_Id
;
1397 -- When the item is not part of the input and the output set of
1398 -- the related subprogram, then it appears as extra in pragma
1399 -- [Refined_]Depends.
1401 if not Item_Is_Input
and then not Item_Is_Output
then
1402 Add_Item_To_Name_Buffer
(Item_Id
);
1403 Add_Str_To_Name_Buffer
1404 (" & cannot appear in dependence relation");
1406 Error_Msg
:= Name_Find
;
1407 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1409 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1411 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1412 & "set of subprogram %"), Item
, Item_Id
);
1414 -- The mode of the item and its role in pragma [Refined_]Depends
1415 -- are in conflict. Construct a detailed message explaining the
1416 -- illegality (SPARK RM 6.1.5(5-6)).
1419 if Item_Is_Input
then
1420 Add_Str_To_Name_Buffer
("read-only");
1422 Add_Str_To_Name_Buffer
("write-only");
1425 Add_Char_To_Name_Buffer
(' ');
1426 Add_Item_To_Name_Buffer
(Item_Id
);
1427 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1429 if Item_Is_Input
then
1430 Add_Str_To_Name_Buffer
("output");
1432 Add_Str_To_Name_Buffer
("input");
1435 Add_Str_To_Name_Buffer
(" in dependence relation");
1436 Error_Msg
:= Name_Find
;
1437 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1443 Item_Is_Input
: Boolean;
1444 Item_Is_Output
: Boolean;
1446 -- Start of processing for Check_Role
1449 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1454 if not Item_Is_Input
then
1455 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1458 -- Self-referential item
1461 if not Item_Is_Input
or else not Item_Is_Output
then
1462 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1467 elsif not Item_Is_Output
then
1468 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1476 procedure Check_Usage
1477 (Subp_Items
: Elist_Id
;
1478 Used_Items
: Elist_Id
;
1481 procedure Usage_Error
(Item_Id
: Entity_Id
);
1482 -- Emit an error concerning the illegal usage of an item
1488 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1489 Error_Msg
: Name_Id
;
1496 -- Unconstrained and tagged items are not part of the explicit
1497 -- input set of the related subprogram, they do not have to be
1498 -- present in a dependence relation and should not be flagged
1499 -- (SPARK RM 6.1.5(5)).
1501 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1504 Add_Item_To_Name_Buffer
(Item_Id
);
1505 Add_Str_To_Name_Buffer
1506 (" & is missing from input dependence list");
1508 Error_Msg
:= Name_Find
;
1509 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1511 ("\add `null ='> &` dependency to ignore this input",
1515 -- Output case (SPARK RM 6.1.5(10))
1520 Add_Item_To_Name_Buffer
(Item_Id
);
1521 Add_Str_To_Name_Buffer
1522 (" & is missing from output dependence list");
1524 Error_Msg
:= Name_Find
;
1525 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1533 Item_Id
: Entity_Id
;
1535 -- Start of processing for Check_Usage
1538 if No
(Subp_Items
) then
1542 -- Each input or output of the subprogram must appear in a dependency
1545 Elmt
:= First_Elmt
(Subp_Items
);
1546 while Present
(Elmt
) loop
1547 Item
:= Node
(Elmt
);
1549 if Nkind
(Item
) = N_Defining_Identifier
then
1552 Item_Id
:= Entity_Of
(Item
);
1555 -- The item does not appear in a dependency
1557 if Present
(Item_Id
)
1558 and then not Contains
(Used_Items
, Item_Id
)
1560 if Is_Formal
(Item_Id
) then
1561 Usage_Error
(Item_Id
);
1563 -- The current instance of a protected type behaves as a formal
1564 -- parameter (SPARK RM 6.1.4).
1566 elsif Ekind
(Item_Id
) = E_Protected_Type
1567 or else Is_Single_Protected_Object
(Item_Id
)
1569 Usage_Error
(Item_Id
);
1571 -- The current instance of a task type behaves as a formal
1572 -- parameter (SPARK RM 6.1.4).
1574 elsif Ekind
(Item_Id
) = E_Task_Type
1575 or else Is_Single_Task_Object
(Item_Id
)
1577 -- The dependence of a task unit on itself is implicit and
1578 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1579 -- Emit an error if only one input/output is present.
1581 if Task_Input_Seen
/= Task_Output_Seen
then
1582 Usage_Error
(Item_Id
);
1585 -- States and global objects are not used properly only when
1586 -- the subprogram is subject to pragma Global.
1588 elsif Global_Seen
then
1589 Usage_Error
(Item_Id
);
1597 ----------------------
1598 -- Normalize_Clause --
1599 ----------------------
1601 procedure Normalize_Clause
(Clause
: Node_Id
) is
1602 procedure Create_Or_Modify_Clause
1608 Multiple
: Boolean);
1609 -- Create a brand new clause to represent the self-reference or
1610 -- modify the input and/or output lists of an existing clause. Output
1611 -- denotes a self-referencial output. Outputs is the output list of a
1612 -- clause. Inputs is the input list of a clause. After denotes the
1613 -- clause after which the new clause is to be inserted. Flag In_Place
1614 -- should be set when normalizing the last output of an output list.
1615 -- Flag Multiple should be set when Output comes from a list with
1618 -----------------------------
1619 -- Create_Or_Modify_Clause --
1620 -----------------------------
1622 procedure Create_Or_Modify_Clause
1630 procedure Propagate_Output
1633 -- Handle the various cases of output propagation to the input
1634 -- list. Output denotes a self-referencial output item. Inputs
1635 -- is the input list of a clause.
1637 ----------------------
1638 -- Propagate_Output --
1639 ----------------------
1641 procedure Propagate_Output
1645 function In_Input_List
1647 Inputs
: List_Id
) return Boolean;
1648 -- Determine whether a particulat item appears in the input
1649 -- list of a clause.
1655 function In_Input_List
1657 Inputs
: List_Id
) return Boolean
1662 Elmt
:= First
(Inputs
);
1663 while Present
(Elmt
) loop
1664 if Entity_Of
(Elmt
) = Item
then
1676 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1679 -- Start of processing for Propagate_Output
1682 -- The clause is of the form:
1684 -- (Output =>+ null)
1686 -- Remove null input and replace it with a copy of the output:
1688 -- (Output => Output)
1690 if Nkind
(Inputs
) = N_Null
then
1691 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1693 -- The clause is of the form:
1695 -- (Output =>+ (Input1, ..., InputN))
1697 -- Determine whether the output is not already mentioned in the
1698 -- input list and if not, add it to the list of inputs:
1700 -- (Output => (Output, Input1, ..., InputN))
1702 elsif Nkind
(Inputs
) = N_Aggregate
then
1703 Grouped
:= Expressions
(Inputs
);
1705 if not In_Input_List
1709 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1712 -- The clause is of the form:
1714 -- (Output =>+ Input)
1716 -- If the input does not mention the output, group the two
1719 -- (Output => (Output, Input))
1721 elsif Entity_Of
(Inputs
) /= Output_Id
then
1723 Make_Aggregate
(Loc
,
1724 Expressions
=> New_List
(
1725 New_Copy_Tree
(Output
),
1726 New_Copy_Tree
(Inputs
))));
1728 end Propagate_Output
;
1732 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1733 New_Clause
: Node_Id
;
1735 -- Start of processing for Create_Or_Modify_Clause
1738 -- A null output depending on itself does not require any
1741 if Nkind
(Output
) = N_Null
then
1744 -- A function result cannot depend on itself because it cannot
1745 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1747 elsif Is_Attribute_Result
(Output
) then
1748 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1752 -- When performing the transformation in place, simply add the
1753 -- output to the list of inputs (if not already there). This
1754 -- case arises when dealing with the last output of an output
1755 -- list. Perform the normalization in place to avoid generating
1756 -- a malformed tree.
1759 Propagate_Output
(Output
, Inputs
);
1761 -- A list with multiple outputs is slowly trimmed until only
1762 -- one element remains. When this happens, replace aggregate
1763 -- with the element itself.
1767 Rewrite
(Outputs
, Output
);
1773 -- Unchain the output from its output list as it will appear in
1774 -- a new clause. Note that we cannot simply rewrite the output
1775 -- as null because this will violate the semantics of pragma
1780 -- Generate a new clause of the form:
1781 -- (Output => Inputs)
1784 Make_Component_Association
(Loc
,
1785 Choices
=> New_List
(Output
),
1786 Expression
=> New_Copy_Tree
(Inputs
));
1788 -- The new clause contains replicated content that has already
1789 -- been analyzed. There is not need to reanalyze or renormalize
1792 Set_Analyzed
(New_Clause
);
1795 (Output
=> First
(Choices
(New_Clause
)),
1796 Inputs
=> Expression
(New_Clause
));
1798 Insert_After
(After
, New_Clause
);
1800 end Create_Or_Modify_Clause
;
1804 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1806 Last_Output
: Node_Id
;
1807 Next_Output
: Node_Id
;
1810 -- Start of processing for Normalize_Clause
1813 -- A self-dependency appears as operator "+". Remove the "+" from the
1814 -- tree by moving the real inputs to their proper place.
1816 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1817 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1818 Inputs
:= Expression
(Clause
);
1820 -- Multiple outputs appear as an aggregate
1822 if Nkind
(Outputs
) = N_Aggregate
then
1823 Last_Output
:= Last
(Expressions
(Outputs
));
1825 Output
:= First
(Expressions
(Outputs
));
1826 while Present
(Output
) loop
1828 -- Normalization may remove an output from its list,
1829 -- preserve the subsequent output now.
1831 Next_Output
:= Next
(Output
);
1833 Create_Or_Modify_Clause
1838 In_Place
=> Output
= Last_Output
,
1841 Output
:= Next_Output
;
1847 Create_Or_Modify_Clause
1856 end Normalize_Clause
;
1860 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1861 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1865 Last_Clause
: Node_Id
;
1866 Restore_Scope
: Boolean := False;
1868 -- Start of processing for Analyze_Depends_In_Decl_Part
1871 -- Do not analyze the pragma multiple times
1873 if Is_Analyzed_Pragma
(N
) then
1877 -- Empty dependency list
1879 if Nkind
(Deps
) = N_Null
then
1881 -- Gather all states, objects and formal parameters that the
1882 -- subprogram may depend on. These items are obtained from the
1883 -- parameter profile or pragma [Refined_]Global (if available).
1885 Collect_Subprogram_Inputs_Outputs
1886 (Subp_Id
=> Subp_Id
,
1887 Subp_Inputs
=> Subp_Inputs
,
1888 Subp_Outputs
=> Subp_Outputs
,
1889 Global_Seen
=> Global_Seen
);
1891 -- Verify that every input or output of the subprogram appear in a
1894 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1895 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1896 Check_Function_Return
;
1898 -- Dependency clauses appear as component associations of an aggregate
1900 elsif Nkind
(Deps
) = N_Aggregate
then
1902 -- Do not attempt to perform analysis of a syntactically illegal
1903 -- clause as this will lead to misleading errors.
1905 if Has_Extra_Parentheses
(Deps
) then
1909 if Present
(Component_Associations
(Deps
)) then
1910 Last_Clause
:= Last
(Component_Associations
(Deps
));
1912 -- Gather all states, objects and formal parameters that the
1913 -- subprogram may depend on. These items are obtained from the
1914 -- parameter profile or pragma [Refined_]Global (if available).
1916 Collect_Subprogram_Inputs_Outputs
1917 (Subp_Id
=> Subp_Id
,
1918 Subp_Inputs
=> Subp_Inputs
,
1919 Subp_Outputs
=> Subp_Outputs
,
1920 Global_Seen
=> Global_Seen
);
1922 -- When pragma [Refined_]Depends appears on a single concurrent
1923 -- type, it is relocated to the anonymous object.
1925 if Is_Single_Concurrent_Object
(Spec_Id
) then
1928 -- Ensure that the formal parameters are visible when analyzing
1929 -- all clauses. This falls out of the general rule of aspects
1930 -- pertaining to subprogram declarations.
1932 elsif not In_Open_Scopes
(Spec_Id
) then
1933 Restore_Scope
:= True;
1934 Push_Scope
(Spec_Id
);
1936 if Ekind
(Spec_Id
) = E_Task_Type
then
1937 if Has_Discriminants
(Spec_Id
) then
1938 Install_Discriminants
(Spec_Id
);
1941 elsif Is_Generic_Subprogram
(Spec_Id
) then
1942 Install_Generic_Formals
(Spec_Id
);
1945 Install_Formals
(Spec_Id
);
1949 Clause
:= First
(Component_Associations
(Deps
));
1950 while Present
(Clause
) loop
1951 Errors
:= Serious_Errors_Detected
;
1953 -- The normalization mechanism may create extra clauses that
1954 -- contain replicated input and output names. There is no need
1955 -- to reanalyze them.
1957 if not Analyzed
(Clause
) then
1958 Set_Analyzed
(Clause
);
1960 Analyze_Dependency_Clause
1962 Is_Last
=> Clause
= Last_Clause
);
1965 -- Do not normalize a clause if errors were detected (count
1966 -- of Serious_Errors has increased) because the inputs and/or
1967 -- outputs may denote illegal items. Normalization is disabled
1968 -- in ASIS mode as it alters the tree by introducing new nodes
1969 -- similar to expansion.
1971 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1972 Normalize_Clause
(Clause
);
1978 if Restore_Scope
then
1982 -- Verify that every input or output of the subprogram appear in a
1985 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1986 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1987 Check_Function_Return
;
1989 -- The dependency list is malformed. This is a syntax error, always
1993 Error_Msg_N
("malformed dependency relation", Deps
);
1997 -- The top level dependency relation is malformed. This is a syntax
1998 -- error, always report.
2001 Error_Msg_N
("malformed dependency relation", Deps
);
2005 -- Ensure that a state and a corresponding constituent do not appear
2006 -- together in pragma [Refined_]Depends.
2008 Check_State_And_Constituent_Use
2009 (States
=> States_Seen
,
2010 Constits
=> Constits_Seen
,
2014 Set_Is_Analyzed_Pragma
(N
);
2015 end Analyze_Depends_In_Decl_Part
;
2017 --------------------------------------------
2018 -- Analyze_External_Property_In_Decl_Part --
2019 --------------------------------------------
2021 procedure Analyze_External_Property_In_Decl_Part
2023 Expr_Val
: out Boolean)
2025 Arg1
: constant Node_Id
:=
2026 First
(Pragma_Argument_Associations
(N
));
2027 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2028 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2034 -- Do not analyze the pragma multiple times
2036 if Is_Analyzed_Pragma
(N
) then
2040 Error_Msg_Name_1
:= Pragma_Name
(N
);
2042 -- An external property pragma must apply to an effectively volatile
2043 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2044 -- The check is performed at the end of the declarative region due to a
2045 -- possible out-of-order arrangement of pragmas:
2048 -- pragma Async_Readers (Obj);
2049 -- pragma Volatile (Obj);
2051 if not Is_Effectively_Volatile
(Obj_Id
) then
2053 ("external property % must apply to a volatile object", N
);
2056 -- Ensure that the Boolean expression (if present) is static. A missing
2057 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2061 if Present
(Arg1
) then
2062 Expr
:= Get_Pragma_Arg
(Arg1
);
2064 if Is_OK_Static_Expression
(Expr
) then
2065 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2069 Set_Is_Analyzed_Pragma
(N
);
2070 end Analyze_External_Property_In_Decl_Part
;
2072 ---------------------------------
2073 -- Analyze_Global_In_Decl_Part --
2074 ---------------------------------
2076 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2077 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2078 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2079 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2081 Constits_Seen
: Elist_Id
:= No_Elist
;
2082 -- A list containing the entities of all constituents processed so far.
2083 -- It aids in detecting illegal usage of a state and a corresponding
2084 -- constituent in pragma [Refinde_]Global.
2086 Seen
: Elist_Id
:= No_Elist
;
2087 -- A list containing the entities of all the items processed so far. It
2088 -- plays a role in detecting distinct entities.
2090 States_Seen
: Elist_Id
:= No_Elist
;
2091 -- A list containing the entities of all states processed so far. It
2092 -- helps in detecting illegal usage of a state and a corresponding
2093 -- constituent in pragma [Refined_]Global.
2095 In_Out_Seen
: Boolean := False;
2096 Input_Seen
: Boolean := False;
2097 Output_Seen
: Boolean := False;
2098 Proof_Seen
: Boolean := False;
2099 -- Flags used to verify the consistency of modes
2101 procedure Analyze_Global_List
2103 Global_Mode
: Name_Id
:= Name_Input
);
2104 -- Verify the legality of a single global list declaration. Global_Mode
2105 -- denotes the current mode in effect.
2107 -------------------------
2108 -- Analyze_Global_List --
2109 -------------------------
2111 procedure Analyze_Global_List
2113 Global_Mode
: Name_Id
:= Name_Input
)
2115 procedure Analyze_Global_Item
2117 Global_Mode
: Name_Id
);
2118 -- Verify the legality of a single global item declaration denoted by
2119 -- Item. Global_Mode denotes the current mode in effect.
2121 procedure Check_Duplicate_Mode
2123 Status
: in out Boolean);
2124 -- Flag Status denotes whether a particular mode has been seen while
2125 -- processing a global list. This routine verifies that Mode is not a
2126 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2128 procedure Check_Mode_Restriction_In_Enclosing_Context
2130 Item_Id
: Entity_Id
);
2131 -- Verify that an item of mode In_Out or Output does not appear as
2132 -- an input in the Global aspect of an enclosing subprogram or task
2133 -- unit. If this is the case, emit an error. Item and Item_Id are
2134 -- respectively the item and its entity.
2136 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2137 -- Mode denotes either In_Out or Output. Depending on the kind of the
2138 -- related subprogram, emit an error if those two modes apply to a
2139 -- function (SPARK RM 6.1.4(10)).
2141 -------------------------
2142 -- Analyze_Global_Item --
2143 -------------------------
2145 procedure Analyze_Global_Item
2147 Global_Mode
: Name_Id
)
2149 Item_Id
: Entity_Id
;
2152 -- Detect one of the following cases
2154 -- with Global => (null, Name)
2155 -- with Global => (Name_1, null, Name_2)
2156 -- with Global => (Name, null)
2158 if Nkind
(Item
) = N_Null
then
2159 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2164 Resolve_State
(Item
);
2166 -- Find the entity of the item. If this is a renaming, climb the
2167 -- renaming chain to reach the root object. Renamings of non-
2168 -- entire objects do not yield an entity (Empty).
2170 Item_Id
:= Entity_Of
(Item
);
2172 if Present
(Item_Id
) then
2174 -- A global item may denote a formal parameter of an enclosing
2175 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2176 -- provide a better error diagnostic.
2178 if Is_Formal
(Item_Id
) then
2179 if Scope
(Item_Id
) = Spec_Id
then
2181 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2182 & "parameter of subprogram &"), Item
, Spec_Id
);
2186 -- A global item may denote a concurrent type as long as it is
2187 -- the current instance of an enclosing protected or task type
2188 -- (SPARK RM 6.1.4).
2190 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2191 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2193 -- Pragma [Refined_]Global associated with a protected
2194 -- subprogram cannot mention the current instance of a
2195 -- protected type because the instance behaves as a
2196 -- formal parameter.
2198 if Ekind
(Item_Id
) = E_Protected_Type
then
2199 if Scope
(Spec_Id
) = Item_Id
then
2200 Error_Msg_Name_1
:= Chars
(Item_Id
);
2202 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2203 & "cannot reference current instance of "
2204 & "protected type %"), Item
, Spec_Id
);
2208 -- Pragma [Refined_]Global associated with a task type
2209 -- cannot mention the current instance of a task type
2210 -- because the instance behaves as a formal parameter.
2212 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2213 if Spec_Id
= Item_Id
then
2214 Error_Msg_Name_1
:= Chars
(Item_Id
);
2216 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2217 & "cannot reference current instance of task "
2218 & "type %"), Item
, Spec_Id
);
2223 -- Otherwise the global item denotes a subtype mark that is
2224 -- not a current instance.
2228 ("invalid use of subtype mark in global list", Item
);
2232 -- A global item may denote the anonymous object created for a
2233 -- single protected/task type as long as the current instance
2234 -- is the same single type (SPARK RM 6.1.4).
2236 elsif Is_Single_Concurrent_Object
(Item_Id
)
2237 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2239 -- Pragma [Refined_]Global associated with a protected
2240 -- subprogram cannot mention the current instance of a
2241 -- protected type because the instance behaves as a formal
2244 if Is_Single_Protected_Object
(Item_Id
) then
2245 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2246 Error_Msg_Name_1
:= Chars
(Item_Id
);
2248 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2249 & "cannot reference current instance of protected "
2250 & "type %"), Item
, Spec_Id
);
2254 -- Pragma [Refined_]Global associated with a task type
2255 -- cannot mention the current instance of a task type
2256 -- because the instance behaves as a formal parameter.
2258 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2259 if Spec_Id
= Item_Id
then
2260 Error_Msg_Name_1
:= Chars
(Item_Id
);
2262 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2263 & "cannot reference current instance of task "
2264 & "type %"), Item
, Spec_Id
);
2269 -- A formal object may act as a global item inside a generic
2271 elsif Is_Formal_Object
(Item_Id
) then
2274 -- The only legal references are those to abstract states,
2275 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2277 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2283 ("global item must denote object, state or current "
2284 & "instance of concurrent type", Item
);
2288 -- State related checks
2290 if Ekind
(Item_Id
) = E_Abstract_State
then
2292 -- Package and subprogram bodies are instantiated
2293 -- individually in a separate compiler pass. Due to this
2294 -- mode of instantiation, the refinement of a state may
2295 -- no longer be visible when a subprogram body contract
2296 -- is instantiated. Since the generic template is legal,
2297 -- do not perform this check in the instance to circumvent
2300 if Is_Generic_Instance
(Spec_Id
) then
2303 -- An abstract state with visible refinement cannot appear
2304 -- in pragma [Refined_]Global as its place must be taken by
2305 -- some of its constituents (SPARK RM 6.1.4(7)).
2307 elsif Has_Visible_Refinement
(Item_Id
) then
2309 ("cannot mention state & in global refinement",
2311 SPARK_Msg_N
("\use its constituents instead", Item
);
2314 -- An external state cannot appear as a global item of a
2315 -- nonvolatile function (SPARK RM 7.1.3(8)).
2317 elsif Is_External_State
(Item_Id
)
2318 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2319 and then not Is_Volatile_Function
(Spec_Id
)
2322 ("external state & cannot act as global item of "
2323 & "nonvolatile function", Item
, Item_Id
);
2326 -- If the reference to the abstract state appears in an
2327 -- enclosing package body that will eventually refine the
2328 -- state, record the reference for future checks.
2331 Record_Possible_Body_Reference
2332 (State_Id
=> Item_Id
,
2336 -- Constant related checks
2338 elsif Ekind
(Item_Id
) = E_Constant
then
2340 -- A constant is a read-only item, therefore it cannot act
2343 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2345 ("constant & cannot act as output", Item
, Item_Id
);
2349 -- Loop parameter related checks
2351 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2353 -- A loop parameter is a read-only item, therefore it cannot
2354 -- act as an output.
2356 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2358 ("loop parameter & cannot act as output",
2363 -- Variable related checks. These are only relevant when
2364 -- SPARK_Mode is on as they are not standard Ada legality
2367 elsif SPARK_Mode
= On
2368 and then Ekind
(Item_Id
) = E_Variable
2369 and then Is_Effectively_Volatile
(Item_Id
)
2371 -- An effectively volatile object cannot appear as a global
2372 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2374 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2375 and then not Is_Volatile_Function
(Spec_Id
)
2378 ("volatile object & cannot act as global item of a "
2379 & "function", Item
, Item_Id
);
2382 -- An effectively volatile object with external property
2383 -- Effective_Reads set to True must have mode Output or
2384 -- In_Out (SPARK RM 7.1.3(10)).
2386 elsif Effective_Reads_Enabled
(Item_Id
)
2387 and then Global_Mode
= Name_Input
2390 ("volatile object & with property Effective_Reads must "
2391 & "have mode In_Out or Output", Item
, Item_Id
);
2396 -- When the item renames an entire object, replace the item
2397 -- with a reference to the object.
2399 if Entity
(Item
) /= Item_Id
then
2400 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2404 -- Some form of illegal construct masquerading as a name
2405 -- (SPARK RM 6.1.4(4)).
2409 ("global item must denote object, state or current instance "
2410 & "of concurrent type", Item
);
2414 -- Verify that an output does not appear as an input in an
2415 -- enclosing subprogram.
2417 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2418 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2421 -- The same entity might be referenced through various way.
2422 -- Check the entity of the item rather than the item itself
2423 -- (SPARK RM 6.1.4(10)).
2425 if Contains
(Seen
, Item_Id
) then
2426 SPARK_Msg_N
("duplicate global item", Item
);
2428 -- Add the entity of the current item to the list of processed
2432 Append_New_Elmt
(Item_Id
, Seen
);
2434 if Ekind
(Item_Id
) = E_Abstract_State
then
2435 Append_New_Elmt
(Item_Id
, States_Seen
);
2437 -- The variable may eventually become a constituent of a single
2438 -- protected/task type. Record the reference now and verify its
2439 -- legality when analyzing the contract of the variable
2442 elsif Ekind
(Item_Id
) = E_Variable
then
2443 Record_Possible_Part_Of_Reference
2448 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2449 and then Present
(Encapsulating_State
(Item_Id
))
2451 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2454 end Analyze_Global_Item
;
2456 --------------------------
2457 -- Check_Duplicate_Mode --
2458 --------------------------
2460 procedure Check_Duplicate_Mode
2462 Status
: in out Boolean)
2466 SPARK_Msg_N
("duplicate global mode", Mode
);
2470 end Check_Duplicate_Mode
;
2472 -------------------------------------------------
2473 -- Check_Mode_Restriction_In_Enclosing_Context --
2474 -------------------------------------------------
2476 procedure Check_Mode_Restriction_In_Enclosing_Context
2478 Item_Id
: Entity_Id
)
2480 Context
: Entity_Id
;
2482 Inputs
: Elist_Id
:= No_Elist
;
2483 Outputs
: Elist_Id
:= No_Elist
;
2486 -- Traverse the scope stack looking for enclosing subprograms or
2487 -- tasks subject to pragma [Refined_]Global.
2489 Context
:= Scope
(Subp_Id
);
2490 while Present
(Context
) and then Context
/= Standard_Standard
loop
2492 -- For a single task type, retrieve the corresponding object to
2493 -- which pragma [Refined_]Global is attached.
2495 if Ekind
(Context
) = E_Task_Type
2496 and then Is_Single_Concurrent_Type
(Context
)
2498 Context
:= Anonymous_Object
(Context
);
2501 if (Is_Subprogram
(Context
)
2502 or else Ekind
(Context
) = E_Task_Type
2503 or else Is_Single_Task_Object
(Context
))
2505 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2507 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2509 Collect_Subprogram_Inputs_Outputs
2510 (Subp_Id
=> Context
,
2511 Subp_Inputs
=> Inputs
,
2512 Subp_Outputs
=> Outputs
,
2513 Global_Seen
=> Dummy
);
2515 -- The item is classified as In_Out or Output but appears as
2516 -- an Input in an enclosing subprogram or task unit (SPARK
2519 if Appears_In
(Inputs
, Item_Id
)
2520 and then not Appears_In
(Outputs
, Item_Id
)
2523 ("global item & cannot have mode In_Out or Output",
2526 if Is_Subprogram
(Context
) then
2528 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2529 & "of subprogram &"), Item
, Context
);
2532 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2533 & "of task &"), Item
, Context
);
2536 -- Stop the traversal once an error has been detected
2542 Context
:= Scope
(Context
);
2544 end Check_Mode_Restriction_In_Enclosing_Context
;
2546 ----------------------------------------
2547 -- Check_Mode_Restriction_In_Function --
2548 ----------------------------------------
2550 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2552 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2554 ("global mode & is not applicable to functions", Mode
);
2556 end Check_Mode_Restriction_In_Function
;
2564 -- Start of processing for Analyze_Global_List
2567 if Nkind
(List
) = N_Null
then
2568 Set_Analyzed
(List
);
2570 -- Single global item declaration
2572 elsif Nkind_In
(List
, N_Expanded_Name
,
2574 N_Selected_Component
)
2576 Analyze_Global_Item
(List
, Global_Mode
);
2578 -- Simple global list or moded global list declaration
2580 elsif Nkind
(List
) = N_Aggregate
then
2581 Set_Analyzed
(List
);
2583 -- The declaration of a simple global list appear as a collection
2586 if Present
(Expressions
(List
)) then
2587 if Present
(Component_Associations
(List
)) then
2589 ("cannot mix moded and non-moded global lists", List
);
2592 Item
:= First
(Expressions
(List
));
2593 while Present
(Item
) loop
2594 Analyze_Global_Item
(Item
, Global_Mode
);
2598 -- The declaration of a moded global list appears as a collection
2599 -- of component associations where individual choices denote
2602 elsif Present
(Component_Associations
(List
)) then
2603 if Present
(Expressions
(List
)) then
2605 ("cannot mix moded and non-moded global lists", List
);
2608 Assoc
:= First
(Component_Associations
(List
));
2609 while Present
(Assoc
) loop
2610 Mode
:= First
(Choices
(Assoc
));
2612 if Nkind
(Mode
) = N_Identifier
then
2613 if Chars
(Mode
) = Name_In_Out
then
2614 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2615 Check_Mode_Restriction_In_Function
(Mode
);
2617 elsif Chars
(Mode
) = Name_Input
then
2618 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2620 elsif Chars
(Mode
) = Name_Output
then
2621 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2622 Check_Mode_Restriction_In_Function
(Mode
);
2624 elsif Chars
(Mode
) = Name_Proof_In
then
2625 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2628 SPARK_Msg_N
("invalid mode selector", Mode
);
2632 SPARK_Msg_N
("invalid mode selector", Mode
);
2635 -- Items in a moded list appear as a collection of
2636 -- expressions. Reuse the existing machinery to analyze
2640 (List
=> Expression
(Assoc
),
2641 Global_Mode
=> Chars
(Mode
));
2649 raise Program_Error
;
2652 -- Any other attempt to declare a global item is illegal. This is a
2653 -- syntax error, always report.
2656 Error_Msg_N
("malformed global list", List
);
2658 end Analyze_Global_List
;
2662 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2664 Restore_Scope
: Boolean := False;
2666 -- Start of processing for Analyze_Global_In_Decl_Part
2669 -- Do not analyze the pragma multiple times
2671 if Is_Analyzed_Pragma
(N
) then
2675 -- There is nothing to be done for a null global list
2677 if Nkind
(Items
) = N_Null
then
2678 Set_Analyzed
(Items
);
2680 -- Analyze the various forms of global lists and items. Note that some
2681 -- of these may be malformed in which case the analysis emits error
2685 -- When pragma [Refined_]Global appears on a single concurrent type,
2686 -- it is relocated to the anonymous object.
2688 if Is_Single_Concurrent_Object
(Spec_Id
) then
2691 -- Ensure that the formal parameters are visible when processing an
2692 -- item. This falls out of the general rule of aspects pertaining to
2693 -- subprogram declarations.
2695 elsif not In_Open_Scopes
(Spec_Id
) then
2696 Restore_Scope
:= True;
2697 Push_Scope
(Spec_Id
);
2699 if Ekind
(Spec_Id
) = E_Task_Type
then
2700 if Has_Discriminants
(Spec_Id
) then
2701 Install_Discriminants
(Spec_Id
);
2704 elsif Is_Generic_Subprogram
(Spec_Id
) then
2705 Install_Generic_Formals
(Spec_Id
);
2708 Install_Formals
(Spec_Id
);
2712 Analyze_Global_List
(Items
);
2714 if Restore_Scope
then
2719 -- Ensure that a state and a corresponding constituent do not appear
2720 -- together in pragma [Refined_]Global.
2722 Check_State_And_Constituent_Use
2723 (States
=> States_Seen
,
2724 Constits
=> Constits_Seen
,
2727 Set_Is_Analyzed_Pragma
(N
);
2728 end Analyze_Global_In_Decl_Part
;
2730 --------------------------------------------
2731 -- Analyze_Initial_Condition_In_Decl_Part --
2732 --------------------------------------------
2734 -- WARNING: This routine manages Ghost regions. Return statements must be
2735 -- replaced by gotos which jump to the end of the routine and restore the
2738 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2739 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2740 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2741 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2743 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2744 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2745 -- Save the Ghost-related attributes to restore on exit
2748 -- Do not analyze the pragma multiple times
2750 if Is_Analyzed_Pragma
(N
) then
2754 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2755 -- analysis of the pragma, the Ghost mode at point of declaration and
2756 -- point of analysis may not necessarily be the same. Use the mode in
2757 -- effect at the point of declaration.
2761 -- The expression is preanalyzed because it has not been moved to its
2762 -- final place yet. A direct analysis may generate side effects and this
2763 -- is not desired at this point.
2765 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2766 Set_Is_Analyzed_Pragma
(N
);
2768 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2769 end Analyze_Initial_Condition_In_Decl_Part
;
2771 --------------------------------------
2772 -- Analyze_Initializes_In_Decl_Part --
2773 --------------------------------------
2775 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2776 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2777 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2779 Constits_Seen
: Elist_Id
:= No_Elist
;
2780 -- A list containing the entities of all constituents processed so far.
2781 -- It aids in detecting illegal usage of a state and a corresponding
2782 -- constituent in pragma Initializes.
2784 Items_Seen
: Elist_Id
:= No_Elist
;
2785 -- A list of all initialization items processed so far. This list is
2786 -- used to detect duplicate items.
2788 States_And_Objs
: Elist_Id
:= No_Elist
;
2789 -- A list of all abstract states and objects declared in the visible
2790 -- declarations of the related package. This list is used to detect the
2791 -- legality of initialization items.
2793 States_Seen
: Elist_Id
:= No_Elist
;
2794 -- A list containing the entities of all states processed so far. It
2795 -- helps in detecting illegal usage of a state and a corresponding
2796 -- constituent in pragma Initializes.
2798 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2799 -- Verify the legality of a single initialization item
2801 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2802 -- Verify the legality of a single initialization item followed by a
2803 -- list of input items.
2805 procedure Collect_States_And_Objects
;
2806 -- Inspect the visible declarations of the related package and gather
2807 -- the entities of all abstract states and objects in States_And_Objs.
2809 ---------------------------------
2810 -- Analyze_Initialization_Item --
2811 ---------------------------------
2813 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2814 Item_Id
: Entity_Id
;
2818 Resolve_State
(Item
);
2820 if Is_Entity_Name
(Item
) then
2821 Item_Id
:= Entity_Of
(Item
);
2823 if Present
(Item_Id
)
2824 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2828 -- When the initialization item is undefined, it appears as
2829 -- Any_Id. Do not continue with the analysis of the item.
2831 if Item_Id
= Any_Id
then
2834 -- The state or variable must be declared in the visible
2835 -- declarations of the package (SPARK RM 7.1.5(7)).
2837 elsif not Contains
(States_And_Objs
, Item_Id
) then
2838 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2840 ("initialization item & must appear in the visible "
2841 & "declarations of package %", Item
, Item_Id
);
2843 -- Detect a duplicate use of the same initialization item
2844 -- (SPARK RM 7.1.5(5)).
2846 elsif Contains
(Items_Seen
, Item_Id
) then
2847 SPARK_Msg_N
("duplicate initialization item", Item
);
2849 -- The item is legal, add it to the list of processed states
2853 Append_New_Elmt
(Item_Id
, Items_Seen
);
2855 if Ekind
(Item_Id
) = E_Abstract_State
then
2856 Append_New_Elmt
(Item_Id
, States_Seen
);
2859 if Present
(Encapsulating_State
(Item_Id
)) then
2860 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2864 -- The item references something that is not a state or object
2865 -- (SPARK RM 7.1.5(3)).
2869 ("initialization item must denote object or state", Item
);
2872 -- Some form of illegal construct masquerading as a name
2873 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2877 ("initialization item must denote object or state", Item
);
2879 end Analyze_Initialization_Item
;
2881 ---------------------------------------------
2882 -- Analyze_Initialization_Item_With_Inputs --
2883 ---------------------------------------------
2885 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2886 Inputs_Seen
: Elist_Id
:= No_Elist
;
2887 -- A list of all inputs processed so far. This list is used to detect
2888 -- duplicate uses of an input.
2890 Non_Null_Seen
: Boolean := False;
2891 Null_Seen
: Boolean := False;
2892 -- Flags used to check the legality of an input list
2894 procedure Analyze_Input_Item
(Input
: Node_Id
);
2895 -- Verify the legality of a single input item
2897 ------------------------
2898 -- Analyze_Input_Item --
2899 ------------------------
2901 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2902 Input_Id
: Entity_Id
;
2907 if Nkind
(Input
) = N_Null
then
2910 ("multiple null initializations not allowed", Item
);
2912 elsif Non_Null_Seen
then
2914 ("cannot mix null and non-null initialization item", Item
);
2922 Non_Null_Seen
:= True;
2926 ("cannot mix null and non-null initialization item", Item
);
2930 Resolve_State
(Input
);
2932 if Is_Entity_Name
(Input
) then
2933 Input_Id
:= Entity_Of
(Input
);
2935 if Present
(Input_Id
)
2936 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2938 E_Generic_In_Out_Parameter
,
2939 E_Generic_In_Parameter
,
2947 -- The input cannot denote states or objects declared
2948 -- within the related package (SPARK RM 7.1.5(4)).
2950 if Within_Scope
(Input_Id
, Current_Scope
) then
2952 -- Do not consider generic formal parameters or their
2953 -- respective mappings to generic formals. Even though
2954 -- the formals appear within the scope of the package,
2955 -- it is allowed for an initialization item to depend
2956 -- on an input item.
2958 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2959 E_Generic_In_Parameter
)
2963 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2964 and then Present
(Corresponding_Generic_Association
2965 (Declaration_Node
(Input_Id
)))
2970 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2972 ("input item & cannot denote a visible object or "
2973 & "state of package %", Input
, Input_Id
);
2978 -- Detect a duplicate use of the same input item
2979 -- (SPARK RM 7.1.5(5)).
2981 if Contains
(Inputs_Seen
, Input_Id
) then
2982 SPARK_Msg_N
("duplicate input item", Input
);
2986 -- At this point it is known that the input is legal. Add
2987 -- it to the list of processed inputs.
2989 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2991 if Ekind
(Input_Id
) = E_Abstract_State
then
2992 Append_New_Elmt
(Input_Id
, States_Seen
);
2995 if Ekind_In
(Input_Id
, E_Abstract_State
,
2998 and then Present
(Encapsulating_State
(Input_Id
))
3000 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3003 -- The input references something that is not a state or an
3004 -- object (SPARK RM 7.1.5(3)).
3008 ("input item must denote object or state", Input
);
3011 -- Some form of illegal construct masquerading as a name
3012 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3016 ("input item must denote object or state", Input
);
3019 end Analyze_Input_Item
;
3023 Inputs
: constant Node_Id
:= Expression
(Item
);
3027 Name_Seen
: Boolean := False;
3028 -- A flag used to detect multiple item names
3030 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3033 -- Inspect the name of an item with inputs
3035 Elmt
:= First
(Choices
(Item
));
3036 while Present
(Elmt
) loop
3038 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3041 Analyze_Initialization_Item
(Elmt
);
3047 -- Multiple input items appear as an aggregate
3049 if Nkind
(Inputs
) = N_Aggregate
then
3050 if Present
(Expressions
(Inputs
)) then
3051 Input
:= First
(Expressions
(Inputs
));
3052 while Present
(Input
) loop
3053 Analyze_Input_Item
(Input
);
3058 if Present
(Component_Associations
(Inputs
)) then
3060 ("inputs must appear in named association form", Inputs
);
3063 -- Single input item
3066 Analyze_Input_Item
(Inputs
);
3068 end Analyze_Initialization_Item_With_Inputs
;
3070 --------------------------------
3071 -- Collect_States_And_Objects --
3072 --------------------------------
3074 procedure Collect_States_And_Objects
is
3075 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3079 -- Collect the abstract states defined in the package (if any)
3081 if Present
(Abstract_States
(Pack_Id
)) then
3082 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3085 -- Collect all objects that appear in the visible declarations of the
3088 if Present
(Visible_Declarations
(Pack_Spec
)) then
3089 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3090 while Present
(Decl
) loop
3091 if Comes_From_Source
(Decl
)
3092 and then Nkind_In
(Decl
, N_Object_Declaration
,
3093 N_Object_Renaming_Declaration
)
3095 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3097 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3099 (Anonymous_Object
(Defining_Entity
(Decl
)),
3106 end Collect_States_And_Objects
;
3110 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3113 -- Start of processing for Analyze_Initializes_In_Decl_Part
3116 -- Do not analyze the pragma multiple times
3118 if Is_Analyzed_Pragma
(N
) then
3122 -- Nothing to do when the initialization list is empty
3124 if Nkind
(Inits
) = N_Null
then
3128 -- Single and multiple initialization clauses appear as an aggregate. If
3129 -- this is not the case, then either the parser or the analysis of the
3130 -- pragma failed to produce an aggregate.
3132 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3134 -- Initialize the various lists used during analysis
3136 Collect_States_And_Objects
;
3138 if Present
(Expressions
(Inits
)) then
3139 Init
:= First
(Expressions
(Inits
));
3140 while Present
(Init
) loop
3141 Analyze_Initialization_Item
(Init
);
3146 if Present
(Component_Associations
(Inits
)) then
3147 Init
:= First
(Component_Associations
(Inits
));
3148 while Present
(Init
) loop
3149 Analyze_Initialization_Item_With_Inputs
(Init
);
3154 -- Ensure that a state and a corresponding constituent do not appear
3155 -- together in pragma Initializes.
3157 Check_State_And_Constituent_Use
3158 (States
=> States_Seen
,
3159 Constits
=> Constits_Seen
,
3162 Set_Is_Analyzed_Pragma
(N
);
3163 end Analyze_Initializes_In_Decl_Part
;
3165 ---------------------
3166 -- Analyze_Part_Of --
3167 ---------------------
3169 procedure Analyze_Part_Of
3171 Item_Id
: Entity_Id
;
3173 Encap_Id
: out Entity_Id
;
3174 Legal
: out Boolean)
3176 procedure Check_Part_Of_Abstract_State
;
3177 pragma Inline
(Check_Part_Of_Abstract_State
);
3178 -- Verify the legality of indicator Part_Of when the encapsulator is an
3181 procedure Check_Part_Of_Concurrent_Type
;
3182 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3183 -- Verify the legality of indicator Part_Of when the encapsulator is a
3184 -- single concurrent type.
3186 ----------------------------------
3187 -- Check_Part_Of_Abstract_State --
3188 ----------------------------------
3190 procedure Check_Part_Of_Abstract_State
is
3191 Pack_Id
: Entity_Id
;
3192 Placement
: State_Space_Kind
;
3193 Parent_Unit
: Entity_Id
;
3196 -- Determine where the object, package instantiation or state lives
3197 -- with respect to the enclosing packages or package bodies.
3199 Find_Placement_In_State_Space
3200 (Item_Id
=> Item_Id
,
3201 Placement
=> Placement
,
3202 Pack_Id
=> Pack_Id
);
3204 -- The item appears in a non-package construct with a declarative
3205 -- part (subprogram, block, etc). As such, the item is not allowed
3206 -- to be a part of an encapsulating state because the item is not
3209 if Placement
= Not_In_Package
then
3211 ("indicator Part_Of cannot appear in this context "
3212 & "(SPARK RM 7.2.6(5))", Indic
);
3214 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3216 ("\& is not part of the hidden state of package %",
3220 -- The item appears in the visible state space of some package. In
3221 -- general this scenario does not warrant Part_Of except when the
3222 -- package is a nongeneric private child unit and the encapsulating
3223 -- state is declared in a parent unit or a public descendant of that
3226 elsif Placement
= Visible_State_Space
then
3227 if Is_Child_Unit
(Pack_Id
)
3228 and then not Is_Generic_Unit
(Pack_Id
)
3229 and then Is_Private_Descendant
(Pack_Id
)
3231 -- A variable or state abstraction which is part of the visible
3232 -- state of a nongeneric private child unit or its public
3233 -- descendants must have its Part_Of indicator specified. The
3234 -- Part_Of indicator must denote a state declared by either the
3235 -- parent unit of the private unit or by a public descendant of
3236 -- that parent unit.
3238 -- Find the nearest private ancestor (which can be the current
3241 Parent_Unit
:= Pack_Id
;
3242 while Present
(Parent_Unit
) loop
3245 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3246 Parent_Unit
:= Scope
(Parent_Unit
);
3249 Parent_Unit
:= Scope
(Parent_Unit
);
3251 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3253 ("indicator Part_Of must denote abstract state of & or of "
3254 & "its public descendant (SPARK RM 7.2.6(3))",
3255 Indic
, Parent_Unit
);
3258 elsif Scope
(Encap_Id
) = Parent_Unit
3260 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3261 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3267 ("indicator Part_Of must denote abstract state of & or of "
3268 & "its public descendant (SPARK RM 7.2.6(3))",
3269 Indic
, Parent_Unit
);
3273 -- Indicator Part_Of is not needed when the related package is
3274 -- not a nongeneric private child unit or a public descendant
3279 ("indicator Part_Of cannot appear in this context "
3280 & "(SPARK RM 7.2.6(5))", Indic
);
3282 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3284 ("\& is declared in the visible part of package %",
3289 -- When the item appears in the private state space of a package, the
3290 -- encapsulating state must be declared in the same package.
3292 elsif Placement
= Private_State_Space
then
3293 if Scope
(Encap_Id
) /= Pack_Id
then
3295 ("indicator Part_Of must denote an abstract state of "
3296 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3298 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3300 ("\& is declared in the private part of package %",
3305 -- Items declared in the body state space of a package do not need
3306 -- Part_Of indicators as the refinement has already been seen.
3310 ("indicator Part_Of cannot appear in this context "
3311 & "(SPARK RM 7.2.6(5))", Indic
);
3313 if Scope
(Encap_Id
) = Pack_Id
then
3314 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3316 ("\& is declared in the body of package %", Indic
, Item_Id
);
3322 -- At this point it is known that the Part_Of indicator is legal
3325 end Check_Part_Of_Abstract_State
;
3327 -----------------------------------
3328 -- Check_Part_Of_Concurrent_Type --
3329 -----------------------------------
3331 procedure Check_Part_Of_Concurrent_Type
is
3332 function In_Proper_Order
3334 Second
: Node_Id
) return Boolean;
3335 pragma Inline
(In_Proper_Order
);
3336 -- Determine whether node First precedes node Second
3338 procedure Placement_Error
;
3339 pragma Inline
(Placement_Error
);
3340 -- Emit an error concerning the illegal placement of the item with
3341 -- respect to the single concurrent type.
3343 ---------------------
3344 -- In_Proper_Order --
3345 ---------------------
3347 function In_Proper_Order
3349 Second
: Node_Id
) return Boolean
3354 if List_Containing
(First
) = List_Containing
(Second
) then
3356 while Present
(N
) loop
3366 end In_Proper_Order
;
3368 ---------------------
3369 -- Placement_Error --
3370 ---------------------
3372 procedure Placement_Error
is
3375 ("indicator Part_Of must denote a previously declared single "
3376 & "protected type or single task type", Encap
);
3377 end Placement_Error
;
3381 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3382 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3383 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3385 Item_Context
: Node_Id
;
3386 Item_Decl
: Node_Id
;
3387 Prv_Decls
: List_Id
;
3388 Vis_Decls
: List_Id
;
3390 -- Start of processing for Check_Part_Of_Concurrent_Type
3393 -- Only abstract states and variables can act as constituents of an
3394 -- encapsulating single concurrent type.
3396 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3399 -- The constituent is a constant
3401 elsif Ekind
(Item_Id
) = E_Constant
then
3402 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3404 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3405 & "single protected type %"), Indic
, Item_Id
);
3408 -- The constituent is a package instantiation
3411 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3413 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3414 & "constituent of single protected type %"), Indic
, Item_Id
);
3418 -- When the item denotes an abstract state of a nested package, use
3419 -- the declaration of the package to detect proper placement.
3424 -- with Abstract_State => (State with Part_Of => T)
3426 if Ekind
(Item_Id
) = E_Abstract_State
then
3427 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3429 Item_Decl
:= Declaration_Node
(Item_Id
);
3432 Item_Context
:= Parent
(Item_Decl
);
3434 -- The item and the single concurrent type must appear in the same
3435 -- declarative region, with the item following the declaration of
3436 -- the single concurrent type (SPARK RM 9(3)).
3438 if Item_Context
= Encap_Context
then
3439 if Nkind_In
(Item_Context
, N_Package_Specification
,
3440 N_Protected_Definition
,
3443 Prv_Decls
:= Private_Declarations
(Item_Context
);
3444 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3446 -- The placement is OK when the single concurrent type appears
3447 -- within the visible declarations and the item in the private
3453 -- Constit : ... with Part_Of => PO;
3456 if List_Containing
(Encap_Decl
) = Vis_Decls
3457 and then List_Containing
(Item_Decl
) = Prv_Decls
3461 -- The placement is illegal when the item appears within the
3462 -- visible declarations and the single concurrent type is in
3463 -- the private declarations.
3466 -- Constit : ... with Part_Of => PO;
3471 elsif List_Containing
(Item_Decl
) = Vis_Decls
3472 and then List_Containing
(Encap_Decl
) = Prv_Decls
3477 -- Otherwise both the item and the single concurrent type are
3478 -- in the same list. Ensure that the declaration of the single
3479 -- concurrent type precedes that of the item.
3481 elsif not In_Proper_Order
3482 (First
=> Encap_Decl
,
3483 Second
=> Item_Decl
)
3489 -- Otherwise both the item and the single concurrent type are
3490 -- in the same list. Ensure that the declaration of the single
3491 -- concurrent type precedes that of the item.
3493 elsif not In_Proper_Order
3494 (First
=> Encap_Decl
,
3495 Second
=> Item_Decl
)
3501 -- Otherwise the item and the single concurrent type reside within
3502 -- unrelated regions.
3505 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3507 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3508 & "immediately within the same region as single protected "
3509 & "type %"), Indic
, Item_Id
);
3513 -- At this point it is known that the Part_Of indicator is legal
3516 end Check_Part_Of_Concurrent_Type
;
3518 -- Start of processing for Analyze_Part_Of
3521 -- Assume that the indicator is illegal
3526 if Nkind_In
(Encap
, N_Expanded_Name
,
3528 N_Selected_Component
)
3531 Resolve_State
(Encap
);
3533 Encap_Id
:= Entity
(Encap
);
3535 -- The encapsulator is an abstract state
3537 if Ekind
(Encap_Id
) = E_Abstract_State
then
3540 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3542 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3545 -- Otherwise the encapsulator is not a legal choice
3549 ("indicator Part_Of must denote abstract state, single "
3550 & "protected type or single task type", Encap
);
3554 -- This is a syntax error, always report
3558 ("indicator Part_Of must denote abstract state, single protected "
3559 & "type or single task type", Encap
);
3563 -- Catch a case where indicator Part_Of denotes the abstract view of a
3564 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3566 if From_Limited_With
(Encap_Id
)
3567 and then Present
(Non_Limited_View
(Encap_Id
))
3568 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3570 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3571 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3575 -- The encapsulator is an abstract state
3577 if Ekind
(Encap_Id
) = E_Abstract_State
then
3578 Check_Part_Of_Abstract_State
;
3580 -- The encapsulator is a single concurrent type
3583 Check_Part_Of_Concurrent_Type
;
3585 end Analyze_Part_Of
;
3587 ----------------------------------
3588 -- Analyze_Part_Of_In_Decl_Part --
3589 ----------------------------------
3591 procedure Analyze_Part_Of_In_Decl_Part
3593 Freeze_Id
: Entity_Id
:= Empty
)
3595 Encap
: constant Node_Id
:=
3596 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3597 Errors
: constant Nat
:= Serious_Errors_Detected
;
3598 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3599 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3600 Constits
: Elist_Id
;
3601 Encap_Id
: Entity_Id
;
3605 -- Detect any discrepancies between the placement of the variable with
3606 -- respect to general state space and the encapsulating state or single
3613 Encap_Id
=> Encap_Id
,
3616 -- The Part_Of indicator turns the variable into a constituent of the
3617 -- encapsulating state or single concurrent type.
3620 pragma Assert
(Present
(Encap_Id
));
3621 Constits
:= Part_Of_Constituents
(Encap_Id
);
3623 if No
(Constits
) then
3624 Constits
:= New_Elmt_List
;
3625 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3628 Append_Elmt
(Var_Id
, Constits
);
3629 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3631 -- A Part_Of constituent partially refines an abstract state. This
3632 -- property does not apply to protected or task units.
3634 if Ekind
(Encap_Id
) = E_Abstract_State
then
3635 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3639 -- Emit a clarification message when the encapsulator is undefined,
3640 -- possibly due to contract freezing.
3642 if Errors
/= Serious_Errors_Detected
3643 and then Present
(Freeze_Id
)
3644 and then Has_Undefined_Reference
(Encap
)
3646 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3648 end Analyze_Part_Of_In_Decl_Part
;
3650 --------------------
3651 -- Analyze_Pragma --
3652 --------------------
3654 procedure Analyze_Pragma
(N
: Node_Id
) is
3655 Loc
: constant Source_Ptr
:= Sloc
(N
);
3657 Pname
: Name_Id
:= Pragma_Name
(N
);
3658 -- Name of the source pragma, or name of the corresponding aspect for
3659 -- pragmas which originate in a source aspect. In the latter case, the
3660 -- name may be different from the pragma name.
3662 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3664 Pragma_Exit
: exception;
3665 -- This exception is used to exit pragma processing completely. It
3666 -- is used when an error is detected, and no further processing is
3667 -- required. It is also used if an earlier error has left the tree in
3668 -- a state where the pragma should not be processed.
3671 -- Number of pragma argument associations
3677 -- First four pragma arguments (pragma argument association nodes, or
3678 -- Empty if the corresponding argument does not exist).
3680 type Name_List
is array (Natural range <>) of Name_Id
;
3681 type Args_List
is array (Natural range <>) of Node_Id
;
3682 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3684 -----------------------
3685 -- Local Subprograms --
3686 -----------------------
3688 function Acc_First
(N
: Node_Id
) return Node_Id
;
3689 -- Helper function to iterate over arguments given to OpenAcc pragmas
3691 function Acc_Next
(N
: Node_Id
) return Node_Id
;
3692 -- Helper function to iterate over arguments given to OpenAcc pragmas
3694 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3695 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3696 -- get the given string argument, and place it in Name_Buffer, adding
3697 -- leading and trailing asterisks if they are not already present. The
3698 -- caller has already checked that Arg is a static string expression.
3700 procedure Ada_2005_Pragma
;
3701 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3702 -- Ada 95 mode, these are implementation defined pragmas, so should be
3703 -- caught by the No_Implementation_Pragmas restriction.
3705 procedure Ada_2012_Pragma
;
3706 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3707 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3708 -- should be caught by the No_Implementation_Pragmas restriction.
3710 procedure Analyze_Depends_Global
3711 (Spec_Id
: out Entity_Id
;
3712 Subp_Decl
: out Node_Id
;
3713 Legal
: out Boolean);
3714 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3715 -- legality of the placement and related context of the pragma. Spec_Id
3716 -- is the entity of the related subprogram. Subp_Decl is the declaration
3717 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3719 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3720 -- Inspect the remainder of the list containing pragma N and look for
3721 -- a pragma that matches Id. If found, analyze the pragma.
3723 procedure Analyze_Pre_Post_Condition
;
3724 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3726 procedure Analyze_Refined_Depends_Global_Post
3727 (Spec_Id
: out Entity_Id
;
3728 Body_Id
: out Entity_Id
;
3729 Legal
: out Boolean);
3730 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3731 -- Refined_Global and Refined_Post. Verify the legality of the placement
3732 -- and related context of the pragma. Spec_Id is the entity of the
3733 -- related subprogram. Body_Id is the entity of the subprogram body.
3734 -- Flag Legal is set when the pragma is legal.
3736 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3737 -- Perform full analysis of pragma Unmodified and the write aspect of
3738 -- pragma Unused. Flag Is_Unused should be set when verifying the
3739 -- semantics of pragma Unused.
3741 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3742 -- Perform full analysis of pragma Unreferenced and the read aspect of
3743 -- pragma Unused. Flag Is_Unused should be set when verifying the
3744 -- semantics of pragma Unused.
3746 procedure Check_Ada_83_Warning
;
3747 -- Issues a warning message for the current pragma if operating in Ada
3748 -- 83 mode (used for language pragmas that are not a standard part of
3749 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3752 procedure Check_Arg_Count
(Required
: Nat
);
3753 -- Check argument count for pragma is equal to given parameter. If not,
3754 -- then issue an error message and raise Pragma_Exit.
3756 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3757 -- Arg which can either be a pragma argument association, in which case
3758 -- the check is applied to the expression of the association or an
3759 -- expression directly.
3761 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3762 -- Check that an argument has the right form for an EXTERNAL_NAME
3763 -- parameter of an extended import/export pragma. The rule is that the
3764 -- name must be an identifier or string literal (in Ada 83 mode) or a
3765 -- static string expression (in Ada 95 mode).
3767 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3768 -- Check the specified argument Arg to make sure that it is an
3769 -- identifier. If not give error and raise Pragma_Exit.
3771 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3772 -- Check the specified argument Arg to make sure that it is an integer
3773 -- literal. If not give error and raise Pragma_Exit.
3775 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3776 -- Check the specified argument Arg to make sure that it has the proper
3777 -- syntactic form for a local name and meets the semantic requirements
3778 -- for a local name. The local name is analyzed as part of the
3779 -- processing for this call. In addition, the local name is required
3780 -- to represent an entity at the library level.
3782 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3783 -- Check the specified argument Arg to make sure that it has the proper
3784 -- syntactic form for a local name and meets the semantic requirements
3785 -- for a local name. The local name is analyzed as part of the
3786 -- processing for this call.
3788 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3789 -- Check the specified argument Arg to make sure that it is a valid
3790 -- locking policy name. If not give error and raise Pragma_Exit.
3792 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3793 -- Check the specified argument Arg to make sure that it is a valid
3794 -- elaboration policy name. If not give error and raise Pragma_Exit.
3796 procedure Check_Arg_Is_One_Of
3799 procedure Check_Arg_Is_One_Of
3801 N1
, N2
, N3
: Name_Id
);
3802 procedure Check_Arg_Is_One_Of
3804 N1
, N2
, N3
, N4
: Name_Id
);
3805 procedure Check_Arg_Is_One_Of
3807 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3808 -- Check the specified argument Arg to make sure that it is an
3809 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3810 -- present). If not then give error and raise Pragma_Exit.
3812 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3813 -- Check the specified argument Arg to make sure that it is a valid
3814 -- queuing policy name. If not give error and raise Pragma_Exit.
3816 procedure Check_Arg_Is_OK_Static_Expression
3818 Typ
: Entity_Id
:= Empty
);
3819 -- Check the specified argument Arg to make sure that it is a static
3820 -- expression of the given type (i.e. it will be analyzed and resolved
3821 -- using this type, which can be any valid argument to Resolve, e.g.
3822 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3823 -- Typ is left Empty, then any static expression is allowed. Includes
3824 -- checking that the argument does not raise Constraint_Error.
3826 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3827 -- Check the specified argument Arg to make sure that it is a valid task
3828 -- dispatching policy name. If not give error and raise Pragma_Exit.
3830 procedure Check_Arg_Order
(Names
: Name_List
);
3831 -- Checks for an instance of two arguments with identifiers for the
3832 -- current pragma which are not in the sequence indicated by Names,
3833 -- and if so, generates a fatal message about bad order of arguments.
3835 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3836 -- Check there are at least N arguments present
3838 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3839 -- Check there are no more than N arguments present
3841 procedure Check_Component
3844 In_Variant_Part
: Boolean := False);
3845 -- Examine an Unchecked_Union component for correct use of per-object
3846 -- constrained subtypes, and for restrictions on finalizable components.
3847 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3848 -- should be set when Comp comes from a record variant.
3850 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3851 -- Check if a rep item of the same name as the current pragma is already
3852 -- chained as a rep pragma to the given entity. If so give a message
3853 -- about the duplicate, and then raise Pragma_Exit so does not return.
3854 -- Note that if E is a type, then this routine avoids flagging a pragma
3855 -- which applies to a parent type from which E is derived.
3857 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3858 -- Nam is an N_String_Literal node containing the external name set by
3859 -- an Import or Export pragma (or extended Import or Export pragma).
3860 -- This procedure checks for possible duplications if this is the export
3861 -- case, and if found, issues an appropriate error message.
3863 procedure Check_Expr_Is_OK_Static_Expression
3865 Typ
: Entity_Id
:= Empty
);
3866 -- Check the specified expression Expr to make sure that it is a static
3867 -- expression of the given type (i.e. it will be analyzed and resolved
3868 -- using this type, which can be any valid argument to Resolve, e.g.
3869 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3870 -- Typ is left Empty, then any static expression is allowed. Includes
3871 -- checking that the expression does not raise Constraint_Error.
3873 procedure Check_First_Subtype
(Arg
: Node_Id
);
3874 -- Checks that Arg, whose expression is an entity name, references a
3877 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3878 -- Checks that the given argument has an identifier, and if so, requires
3879 -- it to match the given identifier name. If there is no identifier, or
3880 -- a non-matching identifier, then an error message is given and
3881 -- Pragma_Exit is raised.
3883 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3884 -- Checks that the given argument has an identifier, and if so, requires
3885 -- it to match one of the given identifier names. If there is no
3886 -- identifier, or a non-matching identifier, then an error message is
3887 -- given and Pragma_Exit is raised.
3889 procedure Check_In_Main_Program
;
3890 -- Common checks for pragmas that appear within a main program
3891 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3893 procedure Check_Interrupt_Or_Attach_Handler
;
3894 -- Common processing for first argument of pragma Interrupt_Handler or
3895 -- pragma Attach_Handler.
3897 procedure Check_Loop_Pragma_Placement
;
3898 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3899 -- appear immediately within a construct restricted to loops, and that
3900 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3902 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3903 -- Check that pragma appears in a declarative part, or in a package
3904 -- specification, i.e. that it does not occur in a statement sequence
3907 procedure Check_No_Identifier
(Arg
: Node_Id
);
3908 -- Checks that the given argument does not have an identifier. If
3909 -- an identifier is present, then an error message is issued, and
3910 -- Pragma_Exit is raised.
3912 procedure Check_No_Identifiers
;
3913 -- Checks that none of the arguments to the pragma has an identifier.
3914 -- If any argument has an identifier, then an error message is issued,
3915 -- and Pragma_Exit is raised.
3917 procedure Check_No_Link_Name
;
3918 -- Checks that no link name is specified
3920 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3921 -- Checks if the given argument has an identifier, and if so, requires
3922 -- it to match the given identifier name. If there is a non-matching
3923 -- identifier, then an error message is given and Pragma_Exit is raised.
3925 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3926 -- Checks if the given argument has an identifier, and if so, requires
3927 -- it to match the given identifier name. If there is a non-matching
3928 -- identifier, then an error message is given and Pragma_Exit is raised.
3929 -- In this version of the procedure, the identifier name is given as
3930 -- a string with lower case letters.
3932 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3933 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3934 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3935 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3936 -- is an OK static boolean expression. Emit an error if this is not the
3939 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3940 -- Constr is a constraint from an N_Subtype_Indication node from a
3941 -- component constraint in an Unchecked_Union type. This routine checks
3942 -- that the constraint is static as required by the restrictions for
3945 procedure Check_Valid_Configuration_Pragma
;
3946 -- Legality checks for placement of a configuration pragma
3948 procedure Check_Valid_Library_Unit_Pragma
;
3949 -- Legality checks for library unit pragmas. A special case arises for
3950 -- pragmas in generic instances that come from copies of the original
3951 -- library unit pragmas in the generic templates. In the case of other
3952 -- than library level instantiations these can appear in contexts which
3953 -- would normally be invalid (they only apply to the original template
3954 -- and to library level instantiations), and they are simply ignored,
3955 -- which is implemented by rewriting them as null statements.
3957 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3958 -- Check an Unchecked_Union variant for lack of nested variants and
3959 -- presence of at least one component. UU_Typ is the related Unchecked_
3962 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3963 -- Subsidiary routine to the processing of pragmas Abstract_State,
3964 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3965 -- Refined_Global and Refined_State. Transform argument Arg into
3966 -- an aggregate if not one already. N_Null is never transformed.
3967 -- Arg may denote an aspect specification or a pragma argument
3970 procedure Error_Pragma
(Msg
: String);
3971 pragma No_Return
(Error_Pragma
);
3972 -- Outputs error message for current pragma. The message contains a %
3973 -- that will be replaced with the pragma name, and the flag is placed
3974 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3975 -- calls Fix_Error (see spec of that procedure for details).
3977 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3978 pragma No_Return
(Error_Pragma_Arg
);
3979 -- Outputs error message for current pragma. The message may contain
3980 -- a % that will be replaced with the pragma name. The parameter Arg
3981 -- may either be a pragma argument association, in which case the flag
3982 -- is placed on the expression of this association, or an expression,
3983 -- in which case the flag is placed directly on the expression. The
3984 -- message is placed using Error_Msg_N, so the message may also contain
3985 -- an & insertion character which will reference the given Arg value.
3986 -- After placing the message, Pragma_Exit is raised. Note: this routine
3987 -- calls Fix_Error (see spec of that procedure for details).
3989 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3990 pragma No_Return
(Error_Pragma_Arg
);
3991 -- Similar to above form of Error_Pragma_Arg except that two messages
3992 -- are provided, the second is a continuation comment starting with \.
3994 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3995 pragma No_Return
(Error_Pragma_Arg_Ident
);
3996 -- Outputs error message for current pragma. The message may contain a %
3997 -- that will be replaced with the pragma name. The parameter Arg must be
3998 -- a pragma argument association with a non-empty identifier (i.e. its
3999 -- Chars field must be set), and the error message is placed on the
4000 -- identifier. The message is placed using Error_Msg_N so the message
4001 -- may also contain an & insertion character which will reference
4002 -- the identifier. After placing the message, Pragma_Exit is raised.
4003 -- Note: this routine calls Fix_Error (see spec of that procedure for
4006 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4007 pragma No_Return
(Error_Pragma_Ref
);
4008 -- Outputs error message for current pragma. The message may contain
4009 -- a % that will be replaced with the pragma name. The parameter Ref
4010 -- must be an entity whose name can be referenced by & and sloc by #.
4011 -- After placing the message, Pragma_Exit is raised. Note: this routine
4012 -- calls Fix_Error (see spec of that procedure for details).
4014 function Find_Lib_Unit_Name
return Entity_Id
;
4015 -- Used for a library unit pragma to find the entity to which the
4016 -- library unit pragma applies, returns the entity found.
4018 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4019 -- If the pragma is a compilation unit pragma, the id must denote the
4020 -- compilation unit in the same compilation, and the pragma must appear
4021 -- in the list of preceding or trailing pragmas. If it is a program
4022 -- unit pragma that is not a compilation unit pragma, then the
4023 -- identifier must be visible.
4025 function Find_Unique_Parameterless_Procedure
4027 Arg
: Node_Id
) return Entity_Id
;
4028 -- Used for a procedure pragma to find the unique parameterless
4029 -- procedure identified by Name, returns it if it exists, otherwise
4030 -- errors out and uses Arg as the pragma argument for the message.
4032 function Fix_Error
(Msg
: String) return String;
4033 -- This is called prior to issuing an error message. Msg is the normal
4034 -- error message issued in the pragma case. This routine checks for the
4035 -- case of a pragma coming from an aspect in the source, and returns a
4036 -- message suitable for the aspect case as follows:
4038 -- Each substring "pragma" is replaced by "aspect"
4040 -- If "argument of" is at the start of the error message text, it is
4041 -- replaced by "entity for".
4043 -- If "argument" is at the start of the error message text, it is
4044 -- replaced by "entity".
4046 -- So for example, "argument of pragma X must be discrete type"
4047 -- returns "entity for aspect X must be a discrete type".
4049 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4050 -- be different from the pragma name). If the current pragma results
4051 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4052 -- original pragma name.
4054 procedure Gather_Associations
4056 Args
: out Args_List
);
4057 -- This procedure is used to gather the arguments for a pragma that
4058 -- permits arbitrary ordering of parameters using the normal rules
4059 -- for named and positional parameters. The Names argument is a list
4060 -- of Name_Id values that corresponds to the allowed pragma argument
4061 -- association identifiers in order. The result returned in Args is
4062 -- a list of corresponding expressions that are the pragma arguments.
4063 -- Note that this is a list of expressions, not of pragma argument
4064 -- associations (Gather_Associations has completely checked all the
4065 -- optional identifiers when it returns). An entry in Args is Empty
4066 -- on return if the corresponding argument is not present.
4068 procedure GNAT_Pragma
;
4069 -- Called for all GNAT defined pragmas to check the relevant restriction
4070 -- (No_Implementation_Pragmas).
4072 function Is_Before_First_Decl
4073 (Pragma_Node
: Node_Id
;
4074 Decls
: List_Id
) return Boolean;
4075 -- Return True if Pragma_Node is before the first declarative item in
4076 -- Decls where Decls is the list of declarative items.
4078 function Is_Configuration_Pragma
return Boolean;
4079 -- Determines if the placement of the current pragma is appropriate
4080 -- for a configuration pragma.
4082 function Is_In_Context_Clause
return Boolean;
4083 -- Returns True if pragma appears within the context clause of a unit,
4084 -- and False for any other placement (does not generate any messages).
4086 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4087 -- Analyzes the argument, and determines if it is a static string
4088 -- expression, returns True if so, False if non-static or not String.
4089 -- A special case is that a string literal returns True in Ada 83 mode
4090 -- (which has no such thing as static string expressions). Note that
4091 -- the call analyzes its argument, so this cannot be used for the case
4092 -- where an identifier might not be declared.
4094 procedure Pragma_Misplaced
;
4095 pragma No_Return
(Pragma_Misplaced
);
4096 -- Issue fatal error message for misplaced pragma
4098 procedure Process_Atomic_Independent_Shared_Volatile
;
4099 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4100 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4101 -- and treated as being identical in effect to pragma Atomic.
4103 procedure Process_Compile_Time_Warning_Or_Error
;
4104 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4106 procedure Process_Convention
4107 (C
: out Convention_Id
;
4108 Ent
: out Entity_Id
);
4109 -- Common processing for Convention, Interface, Import and Export.
4110 -- Checks first two arguments of pragma, and sets the appropriate
4111 -- convention value in the specified entity or entities. On return
4112 -- C is the convention, Ent is the referenced entity.
4114 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4115 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4116 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4118 procedure Process_Extended_Import_Export_Object_Pragma
4119 (Arg_Internal
: Node_Id
;
4120 Arg_External
: Node_Id
;
4121 Arg_Size
: Node_Id
);
4122 -- Common processing for the pragmas Import/Export_Object. The three
4123 -- arguments correspond to the three named parameters of the pragmas. An
4124 -- argument is empty if the corresponding parameter is not present in
4127 procedure Process_Extended_Import_Export_Internal_Arg
4128 (Arg_Internal
: Node_Id
:= Empty
);
4129 -- Common processing for all extended Import and Export pragmas. The
4130 -- argument is the pragma parameter for the Internal argument. If
4131 -- Arg_Internal is empty or inappropriate, an error message is posted.
4132 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4133 -- set to identify the referenced entity.
4135 procedure Process_Extended_Import_Export_Subprogram_Pragma
4136 (Arg_Internal
: Node_Id
;
4137 Arg_External
: Node_Id
;
4138 Arg_Parameter_Types
: Node_Id
;
4139 Arg_Result_Type
: Node_Id
:= Empty
;
4140 Arg_Mechanism
: Node_Id
;
4141 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4142 -- Common processing for all extended Import and Export pragmas applying
4143 -- to subprograms. The caller omits any arguments that do not apply to
4144 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4145 -- only in the Import_Function and Export_Function cases). The argument
4146 -- names correspond to the allowed pragma association identifiers.
4148 procedure Process_Generic_List
;
4149 -- Common processing for Share_Generic and Inline_Generic
4151 procedure Process_Import_Or_Interface
;
4152 -- Common processing for Import or Interface
4154 procedure Process_Import_Predefined_Type
;
4155 -- Processing for completing a type with pragma Import. This is used
4156 -- to declare types that match predefined C types, especially for cases
4157 -- without corresponding Ada predefined type.
4159 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4160 -- Inline status of a subprogram, indicated as follows:
4161 -- Suppressed: inlining is suppressed for the subprogram
4162 -- Disabled: no inlining is requested for the subprogram
4163 -- Enabled: inlining is requested/required for the subprogram
4165 procedure Process_Inline
(Status
: Inline_Status
);
4166 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4167 -- indicates the inline status specified by the pragma.
4169 procedure Process_Interface_Name
4170 (Subprogram_Def
: Entity_Id
;
4174 -- Given the last two arguments of pragma Import, pragma Export, or
4175 -- pragma Interface_Name, performs validity checks and sets the
4176 -- Interface_Name field of the given subprogram entity to the
4177 -- appropriate external or link name, depending on the arguments given.
4178 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4179 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4180 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4181 -- nor Link_Arg is present, the interface name is set to the default
4182 -- from the subprogram name. In addition, the pragma itself is passed
4183 -- to analyze any expressions in the case the pragma came from an aspect
4186 procedure Process_Interrupt_Or_Attach_Handler
;
4187 -- Common processing for Interrupt and Attach_Handler pragmas
4189 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4190 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4191 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4192 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4193 -- is not set in the Restrictions case.
4195 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4196 -- Common processing for Suppress and Unsuppress. The boolean parameter
4197 -- Suppress_Case is True for the Suppress case, and False for the
4200 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4201 -- Subsidiary to the analysis of pragmas Independent[_Components].
4202 -- Record such a pragma N applied to entity E for future checks.
4204 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4205 -- This procedure sets the Is_Exported flag for the given entity,
4206 -- checking that the entity was not previously imported. Arg is
4207 -- the argument that specified the entity. A check is also made
4208 -- for exporting inappropriate entities.
4210 procedure Set_Extended_Import_Export_External_Name
4211 (Internal_Ent
: Entity_Id
;
4212 Arg_External
: Node_Id
);
4213 -- Common processing for all extended import export pragmas. The first
4214 -- argument, Internal_Ent, is the internal entity, which has already
4215 -- been checked for validity by the caller. Arg_External is from the
4216 -- Import or Export pragma, and may be null if no External parameter
4217 -- was present. If Arg_External is present and is a non-null string
4218 -- (a null string is treated as the default), then the Interface_Name
4219 -- field of Internal_Ent is set appropriately.
4221 procedure Set_Imported
(E
: Entity_Id
);
4222 -- This procedure sets the Is_Imported flag for the given entity,
4223 -- checking that it is not previously exported or imported.
4225 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4226 -- Mech is a parameter passing mechanism (see Import_Function syntax
4227 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4228 -- has the right form, and if not issues an error message. If the
4229 -- argument has the right form then the Mechanism field of Ent is
4230 -- set appropriately.
4232 procedure Set_Rational_Profile
;
4233 -- Activate the set of configuration pragmas and permissions that make
4234 -- up the Rational profile.
4236 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4237 -- Activate the set of configuration pragmas and restrictions that make
4238 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4239 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4240 -- which is used for error messages on any constructs violating the
4243 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
);
4244 -- Make sure the argument of a given Acc_If clause is a Boolean
4246 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
);
4247 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4248 -- Copyout...) is an identifier or an aggregate of identifiers.
4250 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
);
4251 -- Make sure the argument of an OpenAcc clause is an Integer expression
4253 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
);
4254 -- Make sure the argument of an OpenAcc clause is an Integer expression
4255 -- or a list of Integer expressions.
4257 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
);
4258 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4259 -- contains at least N-1 nested loops.
4261 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
);
4262 -- Make sure the argument of the Gang clause of a Loop directive is
4263 -- either an integer expression or a (Static => integer expressions)
4266 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
);
4267 -- When this procedure is called in a construct offloaded by an
4268 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4269 -- not exist on said pragma. In all cases, make sure the argument
4270 -- is an Integer expression.
4272 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
);
4273 -- When this procedure is called in a construct offloaded by an
4274 -- Acc_Parallel pragma, makes sure that no argument has been given.
4275 -- When this procedure is called in a construct offloaded by an
4276 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4277 -- makes sure that the Num_Workers clause does not appear on the
4278 -- Acc_Kernels pragma and that the argument is an integer.
4280 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
);
4281 -- Make sure the reduction clause is an aggregate made of a string
4282 -- representing a supported reduction operation (i.e. "+", "*", "and",
4283 -- "or", "min" or "max") and either an identifier or aggregate of
4286 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
);
4287 -- Makes sure that Clause is either an integer expression or an
4288 -- association with a Static as name and a list of integer expressions
4289 -- or "*" strings on the right hand side.
4295 function Acc_First
(N
: Node_Id
) return Node_Id
is
4297 if Nkind
(N
) = N_Aggregate
then
4298 if Present
(Expressions
(N
)) then
4299 return First
(Expressions
(N
));
4301 elsif Present
(Component_Associations
(N
)) then
4302 return Expression
(First
(Component_Associations
(N
)));
4313 function Acc_Next
(N
: Node_Id
) return Node_Id
is
4315 if Nkind
(Parent
(N
)) = N_Component_Association
then
4316 return Expression
(Next
(Parent
(N
)));
4318 elsif Nkind
(Parent
(N
)) = N_Aggregate
then
4326 ----------------------------------
4327 -- Acquire_Warning_Match_String --
4328 ----------------------------------
4330 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4332 String_To_Name_Buffer
4333 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4335 -- Add asterisk at start if not already there
4337 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4338 Name_Buffer
(2 .. Name_Len
+ 1) :=
4339 Name_Buffer
(1 .. Name_Len
);
4340 Name_Buffer
(1) := '*';
4341 Name_Len
:= Name_Len
+ 1;
4344 -- Add asterisk at end if not already there
4346 if Name_Buffer
(Name_Len
) /= '*' then
4347 Name_Len
:= Name_Len
+ 1;
4348 Name_Buffer
(Name_Len
) := '*';
4350 end Acquire_Warning_Match_String
;
4352 ---------------------
4353 -- Ada_2005_Pragma --
4354 ---------------------
4356 procedure Ada_2005_Pragma
is
4358 if Ada_Version
<= Ada_95
then
4359 Check_Restriction
(No_Implementation_Pragmas
, N
);
4361 end Ada_2005_Pragma
;
4363 ---------------------
4364 -- Ada_2012_Pragma --
4365 ---------------------
4367 procedure Ada_2012_Pragma
is
4369 if Ada_Version
<= Ada_2005
then
4370 Check_Restriction
(No_Implementation_Pragmas
, N
);
4372 end Ada_2012_Pragma
;
4374 ----------------------------
4375 -- Analyze_Depends_Global --
4376 ----------------------------
4378 procedure Analyze_Depends_Global
4379 (Spec_Id
: out Entity_Id
;
4380 Subp_Decl
: out Node_Id
;
4381 Legal
: out Boolean)
4384 -- Assume that the pragma is illegal
4391 Check_Arg_Count
(1);
4393 -- Ensure the proper placement of the pragma. Depends/Global must be
4394 -- associated with a subprogram declaration or a body that acts as a
4397 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4401 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4404 -- Generic subprogram
4406 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4409 -- Object declaration of a single concurrent type
4411 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4412 and then Is_Single_Concurrent_Object
4413 (Unique_Defining_Entity
(Subp_Decl
))
4419 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4422 -- Subprogram body acts as spec
4424 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4425 and then No
(Corresponding_Spec
(Subp_Decl
))
4429 -- Subprogram body stub acts as spec
4431 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4432 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4436 -- Subprogram declaration
4438 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4443 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4451 -- If we get here, then the pragma is legal
4454 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4456 -- When the related context is an entry, the entry must belong to a
4457 -- protected unit (SPARK RM 6.1.4(6)).
4459 if Is_Entry_Declaration
(Spec_Id
)
4460 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4465 -- When the related context is an anonymous object created for a
4466 -- simple concurrent type, the type must be a task
4467 -- (SPARK RM 6.1.4(6)).
4469 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4470 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4476 -- A pragma that applies to a Ghost entity becomes Ghost for the
4477 -- purposes of legality checks and removal of ignored Ghost code.
4479 Mark_Ghost_Pragma
(N
, Spec_Id
);
4480 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4481 end Analyze_Depends_Global
;
4483 ------------------------
4484 -- Analyze_If_Present --
4485 ------------------------
4487 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4491 pragma Assert
(Is_List_Member
(N
));
4493 -- Inspect the declarations or statements following pragma N looking
4494 -- for another pragma whose Id matches the caller's request. If it is
4495 -- available, analyze it.
4498 while Present
(Stmt
) loop
4499 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4500 Analyze_Pragma
(Stmt
);
4503 -- The first source declaration or statement immediately following
4504 -- N ends the region where a pragma may appear.
4506 elsif Comes_From_Source
(Stmt
) then
4512 end Analyze_If_Present
;
4514 --------------------------------
4515 -- Analyze_Pre_Post_Condition --
4516 --------------------------------
4518 procedure Analyze_Pre_Post_Condition
is
4519 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4520 Subp_Decl
: Node_Id
;
4521 Subp_Id
: Entity_Id
;
4523 Duplicates_OK
: Boolean := False;
4524 -- Flag set when a pre/postcondition allows multiple pragmas of the
4527 In_Body_OK
: Boolean := False;
4528 -- Flag set when a pre/postcondition is allowed to appear on a body
4529 -- even though the subprogram may have a spec.
4531 Is_Pre_Post
: Boolean := False;
4532 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4535 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4536 -- Implement rules in AI12-0131: an overriding operation can have
4537 -- a class-wide precondition only if one of its ancestors has an
4538 -- explicit class-wide precondition.
4540 -----------------------------
4541 -- Inherits_Class_Wide_Pre --
4542 -----------------------------
4544 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4545 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4548 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4551 -- Check ancestors on the overriding operation to examine the
4552 -- preconditions that may apply to them.
4554 while Present
(Prev
) loop
4555 Cont
:= Contract
(Prev
);
4556 if Present
(Cont
) then
4557 Prag
:= Pre_Post_Conditions
(Cont
);
4558 while Present
(Prag
) loop
4559 if Pragma_Name
(Prag
) = Name_Precondition
4560 and then Class_Present
(Prag
)
4565 Prag
:= Next_Pragma
(Prag
);
4569 -- For a type derived from a generic formal type, the operation
4570 -- inheriting the condition is a renaming, not an overriding of
4571 -- the operation of the formal. Ditto for an inherited
4572 -- operation which has no explicit contracts.
4574 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4575 or else not Comes_From_Source
(Prev
)
4577 Prev
:= Alias
(Prev
);
4579 Prev
:= Overridden_Operation
(Prev
);
4583 -- If the controlling type of the subprogram has progenitors, an
4584 -- interface operation implemented by the current operation may
4585 -- have a class-wide precondition.
4587 if Has_Interfaces
(Typ
) then
4592 Prim_Elmt
: Elmt_Id
;
4593 Prim_List
: Elist_Id
;
4596 Collect_Interfaces
(Typ
, Ints
);
4597 Elmt
:= First_Elmt
(Ints
);
4599 -- Iterate over the primitive operations of each interface
4601 while Present
(Elmt
) loop
4602 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4603 Prim_Elmt
:= First_Elmt
(Prim_List
);
4604 while Present
(Prim_Elmt
) loop
4605 Prim
:= Node
(Prim_Elmt
);
4606 if Chars
(Prim
) = Chars
(E
)
4607 and then Present
(Contract
(Prim
))
4608 and then Class_Present
4609 (Pre_Post_Conditions
(Contract
(Prim
)))
4614 Next_Elmt
(Prim_Elmt
);
4623 end Inherits_Class_Wide_Pre
;
4625 -- Start of processing for Analyze_Pre_Post_Condition
4628 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4629 -- offer uniformity among the various kinds of pre/postconditions by
4630 -- rewriting the pragma identifier. This allows the retrieval of the
4631 -- original pragma name by routine Original_Aspect_Pragma_Name.
4633 if Comes_From_Source
(N
) then
4634 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4635 Is_Pre_Post
:= True;
4636 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4637 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4639 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4640 Is_Pre_Post
:= True;
4641 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4642 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4646 -- Determine the semantics with respect to duplicates and placement
4647 -- in a body. Pragmas Precondition and Postcondition were introduced
4648 -- before aspects and are not subject to the same aspect-like rules.
4650 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4651 Duplicates_OK
:= True;
4657 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4658 -- argument without an identifier.
4661 Check_Arg_Count
(1);
4662 Check_No_Identifiers
;
4664 -- Pragmas Precondition and Postcondition have complex argument
4668 Check_At_Least_N_Arguments
(1);
4669 Check_At_Most_N_Arguments
(2);
4670 Check_Optional_Identifier
(Arg1
, Name_Check
);
4672 if Present
(Arg2
) then
4673 Check_Optional_Identifier
(Arg2
, Name_Message
);
4674 Preanalyze_Spec_Expression
4675 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4679 -- For a pragma PPC in the extended main source unit, record enabled
4681 -- ??? nothing checks that the pragma is in the main source unit
4683 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4684 Set_SCO_Pragma_Enabled
(Loc
);
4687 -- Ensure the proper placement of the pragma
4690 Find_Related_Declaration_Or_Body
4691 (N
, Do_Checks
=> not Duplicates_OK
);
4693 -- When a pre/postcondition pragma applies to an abstract subprogram,
4694 -- its original form must be an aspect with 'Class.
4696 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4697 if not From_Aspect_Specification
(N
) then
4699 ("pragma % cannot be applied to abstract subprogram");
4701 elsif not Class_Present
(N
) then
4703 ("aspect % requires ''Class for abstract subprogram");
4706 -- Entry declaration
4708 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4711 -- Generic subprogram declaration
4713 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4718 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4719 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4723 -- Subprogram body stub
4725 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4726 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4730 -- Subprogram declaration
4732 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4734 -- AI05-0230: When a pre/postcondition pragma applies to a null
4735 -- procedure, its original form must be an aspect with 'Class.
4737 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4738 and then Null_Present
(Specification
(Subp_Decl
))
4739 and then From_Aspect_Specification
(N
)
4740 and then not Class_Present
(N
)
4742 Error_Pragma
("aspect % requires ''Class for null procedure");
4745 -- Implement the legality checks mandated by AI12-0131:
4746 -- Pre'Class shall not be specified for an overriding primitive
4747 -- subprogram of a tagged type T unless the Pre'Class aspect is
4748 -- specified for the corresponding primitive subprogram of some
4752 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4755 if Class_Present
(N
)
4756 and then Pragma_Name
(N
) = Name_Precondition
4757 and then Present
(Overridden_Operation
(E
))
4758 and then not Inherits_Class_Wide_Pre
(E
)
4761 ("illegal class-wide precondition on overriding operation",
4762 Corresponding_Aspect
(N
));
4766 -- A renaming declaration may inherit a generated pragma, its
4767 -- placement comes from expansion, not from source.
4769 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4770 and then not Comes_From_Source
(N
)
4774 -- Otherwise the placement is illegal
4781 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4783 -- A pragma that applies to a Ghost entity becomes Ghost for the
4784 -- purposes of legality checks and removal of ignored Ghost code.
4786 Mark_Ghost_Pragma
(N
, Subp_Id
);
4788 -- Chain the pragma on the contract for further processing by
4789 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4791 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4793 -- Fully analyze the pragma when it appears inside an entry or
4794 -- subprogram body because it cannot benefit from forward references.
4796 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4798 N_Subprogram_Body_Stub
)
4800 -- The legality checks of pragmas Precondition and Postcondition
4801 -- are affected by the SPARK mode in effect and the volatility of
4802 -- the context. Analyze all pragmas in a specific order.
4804 Analyze_If_Present
(Pragma_SPARK_Mode
);
4805 Analyze_If_Present
(Pragma_Volatile_Function
);
4806 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4808 end Analyze_Pre_Post_Condition
;
4810 -----------------------------------------
4811 -- Analyze_Refined_Depends_Global_Post --
4812 -----------------------------------------
4814 procedure Analyze_Refined_Depends_Global_Post
4815 (Spec_Id
: out Entity_Id
;
4816 Body_Id
: out Entity_Id
;
4817 Legal
: out Boolean)
4819 Body_Decl
: Node_Id
;
4820 Spec_Decl
: Node_Id
;
4823 -- Assume that the pragma is illegal
4830 Check_Arg_Count
(1);
4831 Check_No_Identifiers
;
4833 -- Verify the placement of the pragma and check for duplicates. The
4834 -- pragma must apply to a subprogram body [stub].
4836 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4838 if not Nkind_In
(Body_Decl
, N_Entry_Body
,
4840 N_Subprogram_Body_Stub
,
4848 Body_Id
:= Defining_Entity
(Body_Decl
);
4849 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4851 -- The pragma must apply to the second declaration of a subprogram.
4852 -- In other words, the body [stub] cannot acts as a spec.
4854 if No
(Spec_Id
) then
4855 Error_Pragma
("pragma % cannot apply to a stand alone body");
4858 -- Catch the case where the subprogram body is a subunit and acts as
4859 -- the third declaration of the subprogram.
4861 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4862 Error_Pragma
("pragma % cannot apply to a subunit");
4866 -- A refined pragma can only apply to the body [stub] of a subprogram
4867 -- declared in the visible part of a package. Retrieve the context of
4868 -- the subprogram declaration.
4870 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4872 -- When dealing with protected entries or protected subprograms, use
4873 -- the enclosing protected type as the proper context.
4875 if Ekind_In
(Spec_Id
, E_Entry
,
4879 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4881 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4884 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4886 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4887 & "subprogram declared in a package specification"));
4891 -- If we get here, then the pragma is legal
4895 -- A pragma that applies to a Ghost entity becomes Ghost for the
4896 -- purposes of legality checks and removal of ignored Ghost code.
4898 Mark_Ghost_Pragma
(N
, Spec_Id
);
4900 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4901 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4903 end Analyze_Refined_Depends_Global_Post
;
4905 ----------------------------------
4906 -- Analyze_Unmodified_Or_Unused --
4907 ----------------------------------
4909 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4914 Ghost_Error_Posted
: Boolean := False;
4915 -- Flag set when an error concerning the illegal mix of Ghost and
4916 -- non-Ghost variables is emitted.
4918 Ghost_Id
: Entity_Id
:= Empty
;
4919 -- The entity of the first Ghost variable encountered while
4920 -- processing the arguments of the pragma.
4924 Check_At_Least_N_Arguments
(1);
4926 -- Loop through arguments
4929 while Present
(Arg
) loop
4930 Check_No_Identifier
(Arg
);
4932 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4933 -- in fact generate reference, so that the entity will have a
4934 -- reference, which will inhibit any warnings about it not
4935 -- being referenced, and also properly show up in the ali file
4936 -- as a reference. But this reference is recorded before the
4937 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4938 -- generated for this reference.
4940 Check_Arg_Is_Local_Name
(Arg
);
4941 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4943 if Is_Entity_Name
(Arg_Expr
) then
4944 Arg_Id
:= Entity
(Arg_Expr
);
4946 -- Skip processing the argument if already flagged
4948 if Is_Assignable
(Arg_Id
)
4949 and then not Has_Pragma_Unmodified
(Arg_Id
)
4950 and then not Has_Pragma_Unused
(Arg_Id
)
4952 Set_Has_Pragma_Unmodified
(Arg_Id
);
4955 Set_Has_Pragma_Unused
(Arg_Id
);
4958 -- A pragma that applies to a Ghost entity becomes Ghost for
4959 -- the purposes of legality checks and removal of ignored
4962 Mark_Ghost_Pragma
(N
, Arg_Id
);
4964 -- Capture the entity of the first Ghost variable being
4965 -- processed for error detection purposes.
4967 if Is_Ghost_Entity
(Arg_Id
) then
4968 if No
(Ghost_Id
) then
4972 -- Otherwise the variable is non-Ghost. It is illegal to mix
4973 -- references to Ghost and non-Ghost entities
4976 elsif Present
(Ghost_Id
)
4977 and then not Ghost_Error_Posted
4979 Ghost_Error_Posted
:= True;
4981 Error_Msg_Name_1
:= Pname
;
4983 ("pragma % cannot mention ghost and non-ghost "
4986 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4987 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4989 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4990 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4993 -- Warn if already flagged as Unused or Unmodified
4995 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4996 if Has_Pragma_Unused
(Arg_Id
) then
4998 ("??pragma Unused already given for &!", Arg_Expr
,
5002 ("??pragma Unmodified already given for &!", Arg_Expr
,
5006 -- Otherwise the pragma referenced an illegal entity
5010 ("pragma% can only be applied to a variable", Arg_Expr
);
5016 end Analyze_Unmodified_Or_Unused
;
5018 ------------------------------------
5019 -- Analyze_Unreferenced_Or_Unused --
5020 ------------------------------------
5022 procedure Analyze_Unreferenced_Or_Unused
5023 (Is_Unused
: Boolean := False)
5030 Ghost_Error_Posted
: Boolean := False;
5031 -- Flag set when an error concerning the illegal mix of Ghost and
5032 -- non-Ghost names is emitted.
5034 Ghost_Id
: Entity_Id
:= Empty
;
5035 -- The entity of the first Ghost name encountered while processing
5036 -- the arguments of the pragma.
5040 Check_At_Least_N_Arguments
(1);
5042 -- Check case of appearing within context clause
5044 if not Is_Unused
and then Is_In_Context_Clause
then
5046 -- The arguments must all be units mentioned in a with clause in
5047 -- the same context clause. Note that Par.Prag already checked
5048 -- that the arguments are either identifiers or selected
5052 while Present
(Arg
) loop
5053 Citem
:= First
(List_Containing
(N
));
5054 while Citem
/= N
loop
5055 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5057 if Nkind
(Citem
) = N_With_Clause
5058 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5060 Set_Has_Pragma_Unreferenced
5063 (Library_Unit
(Citem
))));
5064 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5073 ("argument of pragma% is not withed unit", Arg
);
5079 -- Case of not in list of context items
5083 while Present
(Arg
) loop
5084 Check_No_Identifier
(Arg
);
5086 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5087 -- in fact generate reference, so that the entity will have a
5088 -- reference, which will inhibit any warnings about it not
5089 -- being referenced, and also properly show up in the ali file
5090 -- as a reference. But this reference is recorded before the
5091 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5092 -- generated for this reference.
5094 Check_Arg_Is_Local_Name
(Arg
);
5095 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5097 if Is_Entity_Name
(Arg_Expr
) then
5098 Arg_Id
:= Entity
(Arg_Expr
);
5100 -- Warn if already flagged as Unused or Unreferenced and
5101 -- skip processing the argument.
5103 if Has_Pragma_Unreferenced
(Arg_Id
) then
5104 if Has_Pragma_Unused
(Arg_Id
) then
5106 ("??pragma Unused already given for &!", Arg_Expr
,
5110 ("??pragma Unreferenced already given for &!",
5114 -- Apply Unreferenced to the entity
5117 -- If the entity is overloaded, the pragma applies to the
5118 -- most recent overloading, as documented. In this case,
5119 -- name resolution does not generate a reference, so it
5120 -- must be done here explicitly.
5122 if Is_Overloaded
(Arg_Expr
) then
5123 Generate_Reference
(Arg_Id
, N
);
5126 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5129 Set_Has_Pragma_Unused
(Arg_Id
);
5132 -- A pragma that applies to a Ghost entity becomes Ghost
5133 -- for the purposes of legality checks and removal of
5134 -- ignored Ghost code.
5136 Mark_Ghost_Pragma
(N
, Arg_Id
);
5138 -- Capture the entity of the first Ghost name being
5139 -- processed for error detection purposes.
5141 if Is_Ghost_Entity
(Arg_Id
) then
5142 if No
(Ghost_Id
) then
5146 -- Otherwise the name is non-Ghost. It is illegal to mix
5147 -- references to Ghost and non-Ghost entities
5150 elsif Present
(Ghost_Id
)
5151 and then not Ghost_Error_Posted
5153 Ghost_Error_Posted
:= True;
5155 Error_Msg_Name_1
:= Pname
;
5157 ("pragma % cannot mention ghost and non-ghost "
5160 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5162 ("\& # declared as ghost", N
, Ghost_Id
);
5164 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5166 ("\& # declared as non-ghost", N
, Arg_Id
);
5174 end Analyze_Unreferenced_Or_Unused
;
5176 --------------------------
5177 -- Check_Ada_83_Warning --
5178 --------------------------
5180 procedure Check_Ada_83_Warning
is
5182 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5183 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5185 end Check_Ada_83_Warning
;
5187 ---------------------
5188 -- Check_Arg_Count --
5189 ---------------------
5191 procedure Check_Arg_Count
(Required
: Nat
) is
5193 if Arg_Count
/= Required
then
5194 Error_Pragma
("wrong number of arguments for pragma%");
5196 end Check_Arg_Count
;
5198 --------------------------------
5199 -- Check_Arg_Is_External_Name --
5200 --------------------------------
5202 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5203 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5206 if Nkind
(Argx
) = N_Identifier
then
5210 Analyze_And_Resolve
(Argx
, Standard_String
);
5212 if Is_OK_Static_Expression
(Argx
) then
5215 elsif Etype
(Argx
) = Any_Type
then
5218 -- An interesting special case, if we have a string literal and
5219 -- we are in Ada 83 mode, then we allow it even though it will
5220 -- not be flagged as static. This allows expected Ada 83 mode
5221 -- use of external names which are string literals, even though
5222 -- technically these are not static in Ada 83.
5224 elsif Ada_Version
= Ada_83
5225 and then Nkind
(Argx
) = N_String_Literal
5229 -- Here we have a real error (non-static expression)
5232 Error_Msg_Name_1
:= Pname
;
5233 Flag_Non_Static_Expr
5234 (Fix_Error
("argument for pragma% must be a identifier or "
5235 & "static string expression!"), Argx
);
5240 end Check_Arg_Is_External_Name
;
5242 -----------------------------
5243 -- Check_Arg_Is_Identifier --
5244 -----------------------------
5246 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5247 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5249 if Nkind
(Argx
) /= N_Identifier
then
5250 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5252 end Check_Arg_Is_Identifier
;
5254 ----------------------------------
5255 -- Check_Arg_Is_Integer_Literal --
5256 ----------------------------------
5258 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5259 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5261 if Nkind
(Argx
) /= N_Integer_Literal
then
5263 ("argument for pragma% must be integer literal", Argx
);
5265 end Check_Arg_Is_Integer_Literal
;
5267 -------------------------------------------
5268 -- Check_Arg_Is_Library_Level_Local_Name --
5269 -------------------------------------------
5273 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5274 -- | library_unit_NAME
5276 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5278 Check_Arg_Is_Local_Name
(Arg
);
5280 -- If it came from an aspect, we want to give the error just as if it
5281 -- came from source.
5283 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5284 and then (Comes_From_Source
(N
)
5285 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5288 ("argument for pragma% must be library level entity", Arg
);
5290 end Check_Arg_Is_Library_Level_Local_Name
;
5292 -----------------------------
5293 -- Check_Arg_Is_Local_Name --
5294 -----------------------------
5298 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5299 -- | library_unit_NAME
5301 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5302 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5305 -- If this pragma came from an aspect specification, we don't want to
5306 -- check for this error, because that would cause spurious errors, in
5307 -- case a type is frozen in a scope more nested than the type. The
5308 -- aspect itself of course can't be anywhere but on the declaration
5311 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5312 if From_Aspect_Specification
(Parent
(Arg
)) then
5316 -- Arg is the Expression of an N_Pragma_Argument_Association
5319 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5326 if Nkind
(Argx
) not in N_Direct_Name
5327 and then (Nkind
(Argx
) /= N_Attribute_Reference
5328 or else Present
(Expressions
(Argx
))
5329 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5330 and then (not Is_Entity_Name
(Argx
)
5331 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5333 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5336 -- No further check required if not an entity name
5338 if not Is_Entity_Name
(Argx
) then
5344 Ent
: constant Entity_Id
:= Entity
(Argx
);
5345 Scop
: constant Entity_Id
:= Scope
(Ent
);
5348 -- Case of a pragma applied to a compilation unit: pragma must
5349 -- occur immediately after the program unit in the compilation.
5351 if Is_Compilation_Unit
(Ent
) then
5353 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5356 -- Case of pragma placed immediately after spec
5358 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5361 -- Case of pragma placed immediately after body
5363 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5364 and then Present
(Corresponding_Body
(Decl
))
5368 (Parent
(Unit_Declaration_Node
5369 (Corresponding_Body
(Decl
))));
5371 -- All other cases are illegal
5378 -- Special restricted placement rule from 10.2.1(11.8/2)
5380 elsif Is_Generic_Formal
(Ent
)
5381 and then Prag_Id
= Pragma_Preelaborable_Initialization
5383 OK
:= List_Containing
(N
) =
5384 Generic_Formal_Declarations
5385 (Unit_Declaration_Node
(Scop
));
5387 -- If this is an aspect applied to a subprogram body, the
5388 -- pragma is inserted in its declarative part.
5390 elsif From_Aspect_Specification
(N
)
5391 and then Ent
= Current_Scope
5393 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5397 -- If the aspect is a predicate (possibly others ???) and the
5398 -- context is a record type, this is a discriminant expression
5399 -- within a type declaration, that freezes the predicated
5402 elsif From_Aspect_Specification
(N
)
5403 and then Prag_Id
= Pragma_Predicate
5404 and then Ekind
(Current_Scope
) = E_Record_Type
5405 and then Scop
= Scope
(Current_Scope
)
5409 -- Default case, just check that the pragma occurs in the scope
5410 -- of the entity denoted by the name.
5413 OK
:= Current_Scope
= Scop
;
5418 ("pragma% argument must be in same declarative part", Arg
);
5422 end Check_Arg_Is_Local_Name
;
5424 ---------------------------------
5425 -- Check_Arg_Is_Locking_Policy --
5426 ---------------------------------
5428 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5429 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5432 Check_Arg_Is_Identifier
(Argx
);
5434 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5435 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5437 end Check_Arg_Is_Locking_Policy
;
5439 -----------------------------------------------
5440 -- Check_Arg_Is_Partition_Elaboration_Policy --
5441 -----------------------------------------------
5443 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5444 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5447 Check_Arg_Is_Identifier
(Argx
);
5449 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5451 ("& is not a valid partition elaboration policy name", Argx
);
5453 end Check_Arg_Is_Partition_Elaboration_Policy
;
5455 -------------------------
5456 -- Check_Arg_Is_One_Of --
5457 -------------------------
5459 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5460 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5463 Check_Arg_Is_Identifier
(Argx
);
5465 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5466 Error_Msg_Name_2
:= N1
;
5467 Error_Msg_Name_3
:= N2
;
5468 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5470 end Check_Arg_Is_One_Of
;
5472 procedure Check_Arg_Is_One_Of
5474 N1
, N2
, N3
: Name_Id
)
5476 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5479 Check_Arg_Is_Identifier
(Argx
);
5481 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5482 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5484 end Check_Arg_Is_One_Of
;
5486 procedure Check_Arg_Is_One_Of
5488 N1
, N2
, N3
, N4
: Name_Id
)
5490 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5493 Check_Arg_Is_Identifier
(Argx
);
5495 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5496 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5498 end Check_Arg_Is_One_Of
;
5500 procedure Check_Arg_Is_One_Of
5502 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5504 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5507 Check_Arg_Is_Identifier
(Argx
);
5509 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5510 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5512 end Check_Arg_Is_One_Of
;
5514 ---------------------------------
5515 -- Check_Arg_Is_Queuing_Policy --
5516 ---------------------------------
5518 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5519 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5522 Check_Arg_Is_Identifier
(Argx
);
5524 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5525 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5527 end Check_Arg_Is_Queuing_Policy
;
5529 ---------------------------------------
5530 -- Check_Arg_Is_OK_Static_Expression --
5531 ---------------------------------------
5533 procedure Check_Arg_Is_OK_Static_Expression
5535 Typ
: Entity_Id
:= Empty
)
5538 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5539 end Check_Arg_Is_OK_Static_Expression
;
5541 ------------------------------------------
5542 -- Check_Arg_Is_Task_Dispatching_Policy --
5543 ------------------------------------------
5545 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5546 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5549 Check_Arg_Is_Identifier
(Argx
);
5551 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5553 ("& is not an allowed task dispatching policy name", Argx
);
5555 end Check_Arg_Is_Task_Dispatching_Policy
;
5557 ---------------------
5558 -- Check_Arg_Order --
5559 ---------------------
5561 procedure Check_Arg_Order
(Names
: Name_List
) is
5564 Highest_So_Far
: Natural := 0;
5565 -- Highest index in Names seen do far
5569 for J
in 1 .. Arg_Count
loop
5570 if Chars
(Arg
) /= No_Name
then
5571 for K
in Names
'Range loop
5572 if Chars
(Arg
) = Names
(K
) then
5573 if K
< Highest_So_Far
then
5574 Error_Msg_Name_1
:= Pname
;
5576 ("parameters out of order for pragma%", Arg
);
5577 Error_Msg_Name_1
:= Names
(K
);
5578 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5579 Error_Msg_N
("\% must appear before %", Arg
);
5583 Highest_So_Far
:= K
;
5591 end Check_Arg_Order
;
5593 --------------------------------
5594 -- Check_At_Least_N_Arguments --
5595 --------------------------------
5597 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5599 if Arg_Count
< N
then
5600 Error_Pragma
("too few arguments for pragma%");
5602 end Check_At_Least_N_Arguments
;
5604 -------------------------------
5605 -- Check_At_Most_N_Arguments --
5606 -------------------------------
5608 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5611 if Arg_Count
> N
then
5613 for J
in 1 .. N
loop
5615 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5618 end Check_At_Most_N_Arguments
;
5620 ---------------------
5621 -- Check_Component --
5622 ---------------------
5624 procedure Check_Component
5627 In_Variant_Part
: Boolean := False)
5629 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5630 Sindic
: constant Node_Id
:=
5631 Subtype_Indication
(Component_Definition
(Comp
));
5632 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5635 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5636 -- object constraint, then the component type shall be an Unchecked_
5639 if Nkind
(Sindic
) = N_Subtype_Indication
5640 and then Has_Per_Object_Constraint
(Comp_Id
)
5641 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5644 ("component subtype subject to per-object constraint "
5645 & "must be an Unchecked_Union", Comp
);
5647 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5648 -- the body of a generic unit, or within the body of any of its
5649 -- descendant library units, no part of the type of a component
5650 -- declared in a variant_part of the unchecked union type shall be of
5651 -- a formal private type or formal private extension declared within
5652 -- the formal part of the generic unit.
5654 elsif Ada_Version
>= Ada_2012
5655 and then In_Generic_Body
(UU_Typ
)
5656 and then In_Variant_Part
5657 and then Is_Private_Type
(Typ
)
5658 and then Is_Generic_Type
(Typ
)
5661 ("component of unchecked union cannot be of generic type", Comp
);
5663 elsif Needs_Finalization
(Typ
) then
5665 ("component of unchecked union cannot be controlled", Comp
);
5667 elsif Has_Task
(Typ
) then
5669 ("component of unchecked union cannot have tasks", Comp
);
5671 end Check_Component
;
5673 ----------------------------
5674 -- Check_Duplicate_Pragma --
5675 ----------------------------
5677 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5678 Id
: Entity_Id
:= E
;
5682 -- Nothing to do if this pragma comes from an aspect specification,
5683 -- since we could not be duplicating a pragma, and we dealt with the
5684 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5686 if From_Aspect_Specification
(N
) then
5690 -- Otherwise current pragma may duplicate previous pragma or a
5691 -- previously given aspect specification or attribute definition
5692 -- clause for the same pragma.
5694 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5698 -- If the entity is a type, then we have to make sure that the
5699 -- ostensible duplicate is not for a parent type from which this
5703 if Nkind
(P
) = N_Pragma
then
5705 Args
: constant List_Id
:=
5706 Pragma_Argument_Associations
(P
);
5709 and then Is_Entity_Name
(Expression
(First
(Args
)))
5710 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5711 and then Entity
(Expression
(First
(Args
))) /= E
5717 elsif Nkind
(P
) = N_Aspect_Specification
5718 and then Is_Type
(Entity
(P
))
5719 and then Entity
(P
) /= E
5725 -- Here we have a definite duplicate
5727 Error_Msg_Name_1
:= Pragma_Name
(N
);
5728 Error_Msg_Sloc
:= Sloc
(P
);
5730 -- For a single protected or a single task object, the error is
5731 -- issued on the original entity.
5733 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5734 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5737 if Nkind
(P
) = N_Aspect_Specification
5738 or else From_Aspect_Specification
(P
)
5740 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5742 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5747 end Check_Duplicate_Pragma
;
5749 ----------------------------------
5750 -- Check_Duplicated_Export_Name --
5751 ----------------------------------
5753 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5754 String_Val
: constant String_Id
:= Strval
(Nam
);
5757 -- We are only interested in the export case, and in the case of
5758 -- generics, it is the instance, not the template, that is the
5759 -- problem (the template will generate a warning in any case).
5761 if not Inside_A_Generic
5762 and then (Prag_Id
= Pragma_Export
5764 Prag_Id
= Pragma_Export_Procedure
5766 Prag_Id
= Pragma_Export_Valued_Procedure
5768 Prag_Id
= Pragma_Export_Function
)
5770 for J
in Externals
.First
.. Externals
.Last
loop
5771 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5772 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5773 Error_Msg_N
("external name duplicates name given#", Nam
);
5778 Externals
.Append
(Nam
);
5780 end Check_Duplicated_Export_Name
;
5782 ----------------------------------------
5783 -- Check_Expr_Is_OK_Static_Expression --
5784 ----------------------------------------
5786 procedure Check_Expr_Is_OK_Static_Expression
5788 Typ
: Entity_Id
:= Empty
)
5791 if Present
(Typ
) then
5792 Analyze_And_Resolve
(Expr
, Typ
);
5794 Analyze_And_Resolve
(Expr
);
5797 -- An expression cannot be considered static if its resolution failed
5798 -- or if it's erroneous. Stop the analysis of the related pragma.
5800 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5803 elsif Is_OK_Static_Expression
(Expr
) then
5806 -- An interesting special case, if we have a string literal and we
5807 -- are in Ada 83 mode, then we allow it even though it will not be
5808 -- flagged as static. This allows the use of Ada 95 pragmas like
5809 -- Import in Ada 83 mode. They will of course be flagged with
5810 -- warnings as usual, but will not cause errors.
5812 elsif Ada_Version
= Ada_83
5813 and then Nkind
(Expr
) = N_String_Literal
5817 -- Finally, we have a real error
5820 Error_Msg_Name_1
:= Pname
;
5821 Flag_Non_Static_Expr
5822 (Fix_Error
("argument for pragma% must be a static expression!"),
5826 end Check_Expr_Is_OK_Static_Expression
;
5828 -------------------------
5829 -- Check_First_Subtype --
5830 -------------------------
5832 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5833 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5834 Ent
: constant Entity_Id
:= Entity
(Argx
);
5837 if Is_First_Subtype
(Ent
) then
5840 elsif Is_Type
(Ent
) then
5842 ("pragma% cannot apply to subtype", Argx
);
5844 elsif Is_Object
(Ent
) then
5846 ("pragma% cannot apply to object, requires a type", Argx
);
5850 ("pragma% cannot apply to&, requires a type", Argx
);
5852 end Check_First_Subtype
;
5854 ----------------------
5855 -- Check_Identifier --
5856 ----------------------
5858 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5861 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5863 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5864 Error_Msg_Name_1
:= Pname
;
5865 Error_Msg_Name_2
:= Id
;
5866 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5870 end Check_Identifier
;
5872 --------------------------------
5873 -- Check_Identifier_Is_One_Of --
5874 --------------------------------
5876 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5879 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5881 if Chars
(Arg
) = No_Name
then
5882 Error_Msg_Name_1
:= Pname
;
5883 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5886 elsif Chars
(Arg
) /= N1
5887 and then Chars
(Arg
) /= N2
5889 Error_Msg_Name_1
:= Pname
;
5890 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5894 end Check_Identifier_Is_One_Of
;
5896 ---------------------------
5897 -- Check_In_Main_Program --
5898 ---------------------------
5900 procedure Check_In_Main_Program
is
5901 P
: constant Node_Id
:= Parent
(N
);
5904 -- Must be in subprogram body
5906 if Nkind
(P
) /= N_Subprogram_Body
then
5907 Error_Pragma
("% pragma allowed only in subprogram");
5909 -- Otherwise warn if obviously not main program
5911 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5912 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5914 Error_Msg_Name_1
:= Pname
;
5916 ("??pragma% is only effective in main program", N
);
5918 end Check_In_Main_Program
;
5920 ---------------------------------------
5921 -- Check_Interrupt_Or_Attach_Handler --
5922 ---------------------------------------
5924 procedure Check_Interrupt_Or_Attach_Handler
is
5925 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5926 Handler_Proc
, Proc_Scope
: Entity_Id
;
5931 if Prag_Id
= Pragma_Interrupt_Handler
then
5932 Check_Restriction
(No_Dynamic_Attachment
, N
);
5935 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5936 Proc_Scope
:= Scope
(Handler_Proc
);
5938 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5940 ("argument of pragma% must be protected procedure", Arg1
);
5943 -- For pragma case (as opposed to access case), check placement.
5944 -- We don't need to do that for aspects, because we have the
5945 -- check that they aspect applies an appropriate procedure.
5947 if not From_Aspect_Specification
(N
)
5948 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5950 Error_Pragma
("pragma% must be in protected definition");
5953 if not Is_Library_Level_Entity
(Proc_Scope
) then
5955 ("argument for pragma% must be library level entity", Arg1
);
5958 -- AI05-0033: A pragma cannot appear within a generic body, because
5959 -- instance can be in a nested scope. The check that protected type
5960 -- is itself a library-level declaration is done elsewhere.
5962 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5963 -- handle code prior to AI-0033. Analysis tools typically are not
5964 -- interested in this pragma in any case, so no need to worry too
5965 -- much about its placement.
5967 if Inside_A_Generic
then
5968 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5969 and then In_Package_Body
(Scope
(Current_Scope
))
5970 and then not Relaxed_RM_Semantics
5972 Error_Pragma
("pragma% cannot be used inside a generic");
5975 end Check_Interrupt_Or_Attach_Handler
;
5977 ---------------------------------
5978 -- Check_Loop_Pragma_Placement --
5979 ---------------------------------
5981 procedure Check_Loop_Pragma_Placement
is
5982 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5983 -- Verify whether the current pragma is properly grouped with other
5984 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5985 -- related loop where the pragma appears.
5987 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5988 -- Determine whether an arbitrary statement Stmt denotes pragma
5989 -- Loop_Invariant or Loop_Variant.
5991 procedure Placement_Error
(Constr
: Node_Id
);
5992 pragma No_Return
(Placement_Error
);
5993 -- Node Constr denotes the last loop restricted construct before we
5994 -- encountered an illegal relation between enclosing constructs. Emit
5995 -- an error depending on what Constr was.
5997 --------------------------------
5998 -- Check_Loop_Pragma_Grouping --
5999 --------------------------------
6001 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6002 Stop_Search
: exception;
6003 -- This exception is used to terminate the recursive descent of
6004 -- routine Check_Grouping.
6006 procedure Check_Grouping
(L
: List_Id
);
6007 -- Find the first group of pragmas in list L and if successful,
6008 -- ensure that the current pragma is part of that group. The
6009 -- routine raises Stop_Search once such a check is performed to
6010 -- halt the recursive descent.
6012 procedure Grouping_Error
(Prag
: Node_Id
);
6013 pragma No_Return
(Grouping_Error
);
6014 -- Emit an error concerning the current pragma indicating that it
6015 -- should be placed after pragma Prag.
6017 --------------------
6018 -- Check_Grouping --
6019 --------------------
6021 procedure Check_Grouping
(L
: List_Id
) is
6024 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6027 -- Inspect the list of declarations or statements looking for
6028 -- the first grouping of pragmas:
6031 -- pragma Loop_Invariant ...;
6032 -- pragma Loop_Variant ...;
6034 -- pragma Loop_Variant ...; -- current pragma
6036 -- If the current pragma is not in the grouping, then it must
6037 -- either appear in a different declarative or statement list
6038 -- or the construct at (1) is separating the pragma from the
6042 while Present
(Stmt
) loop
6044 -- First pragma of the first topmost grouping has been found
6046 if Is_Loop_Pragma
(Stmt
) then
6048 -- The group and the current pragma are not in the same
6049 -- declarative or statement list.
6051 if List_Containing
(Stmt
) /= List_Containing
(N
) then
6052 Grouping_Error
(Stmt
);
6054 -- Try to reach the current pragma from the first pragma
6055 -- of the grouping while skipping other members:
6057 -- pragma Loop_Invariant ...; -- first pragma
6058 -- pragma Loop_Variant ...; -- member
6060 -- pragma Loop_Variant ...; -- current pragma
6063 while Present
(Stmt
) loop
6064 -- The current pragma is either the first pragma
6065 -- of the group or is a member of the group.
6066 -- Stop the search as the placement is legal.
6071 -- Skip group members, but keep track of the
6072 -- last pragma in the group.
6074 elsif Is_Loop_Pragma
(Stmt
) then
6077 -- Skip declarations and statements generated by
6078 -- the compiler during expansion. Note that some
6079 -- source statements (e.g. pragma Assert) may have
6080 -- been transformed so that they do not appear as
6081 -- coming from source anymore, so we instead look
6082 -- at their Original_Node.
6084 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6088 -- A non-pragma is separating the group from the
6089 -- current pragma, the placement is illegal.
6092 Grouping_Error
(Prag
);
6098 -- If the traversal did not reach the current pragma,
6099 -- then the list must be malformed.
6101 raise Program_Error
;
6104 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6105 -- inside a loop or a block housed inside a loop. Inspect
6106 -- the declarations and statements of the block as they may
6107 -- contain the first grouping. This case follows the one for
6108 -- loop pragmas, as block statements which originate in a
6109 -- loop pragma (and so Is_Loop_Pragma will return True on
6110 -- that block statement) should be treated in the previous
6113 elsif Nkind
(Stmt
) = N_Block_Statement
then
6114 HSS
:= Handled_Statement_Sequence
(Stmt
);
6116 Check_Grouping
(Declarations
(Stmt
));
6118 if Present
(HSS
) then
6119 Check_Grouping
(Statements
(HSS
));
6127 --------------------
6128 -- Grouping_Error --
6129 --------------------
6131 procedure Grouping_Error
(Prag
: Node_Id
) is
6133 Error_Msg_Sloc
:= Sloc
(Prag
);
6134 Error_Pragma
("pragma% must appear next to pragma#");
6137 -- Start of processing for Check_Loop_Pragma_Grouping
6140 -- Inspect the statements of the loop or nested blocks housed
6141 -- within to determine whether the current pragma is part of the
6142 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6144 Check_Grouping
(Statements
(Loop_Stmt
));
6147 when Stop_Search
=> null;
6148 end Check_Loop_Pragma_Grouping
;
6150 --------------------
6151 -- Is_Loop_Pragma --
6152 --------------------
6154 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6156 -- Inspect the original node as Loop_Invariant and Loop_Variant
6157 -- pragmas are rewritten to null when assertions are disabled.
6159 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
6161 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
6162 Name_Loop_Invariant
,
6169 ---------------------
6170 -- Placement_Error --
6171 ---------------------
6173 procedure Placement_Error
(Constr
: Node_Id
) is
6174 LA
: constant String := " with Loop_Entry";
6177 if Prag_Id
= Pragma_Assert
then
6178 Error_Msg_String
(1 .. LA
'Length) := LA
;
6179 Error_Msg_Strlen
:= LA
'Length;
6181 Error_Msg_Strlen
:= 0;
6184 if Nkind
(Constr
) = N_Pragma
then
6186 ("pragma %~ must appear immediately within the statements "
6190 ("block containing pragma %~ must appear immediately within "
6191 & "the statements of a loop", Constr
);
6193 end Placement_Error
;
6195 -- Local declarations
6200 -- Start of processing for Check_Loop_Pragma_Placement
6203 -- Check that pragma appears immediately within a loop statement,
6204 -- ignoring intervening block statements.
6208 while Present
(Stmt
) loop
6210 -- The pragma or previous block must appear immediately within the
6211 -- current block's declarative or statement part.
6213 if Nkind
(Stmt
) = N_Block_Statement
then
6214 if (No
(Declarations
(Stmt
))
6215 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6217 List_Containing
(Prev
) /=
6218 Statements
(Handled_Statement_Sequence
(Stmt
))
6220 Placement_Error
(Prev
);
6223 -- Keep inspecting the parents because we are now within a
6224 -- chain of nested blocks.
6228 Stmt
:= Parent
(Stmt
);
6231 -- The pragma or previous block must appear immediately within the
6232 -- statements of the loop.
6234 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6235 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6236 Placement_Error
(Prev
);
6239 -- Stop the traversal because we reached the innermost loop
6240 -- regardless of whether we encountered an error or not.
6244 -- Ignore a handled statement sequence. Note that this node may
6245 -- be related to a subprogram body in which case we will emit an
6246 -- error on the next iteration of the search.
6248 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6249 Stmt
:= Parent
(Stmt
);
6251 -- Any other statement breaks the chain from the pragma to the
6255 Placement_Error
(Prev
);
6260 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6261 -- grouped together with other such pragmas.
6263 if Is_Loop_Pragma
(N
) then
6265 -- The previous check should have located the related loop
6267 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6268 Check_Loop_Pragma_Grouping
(Stmt
);
6270 end Check_Loop_Pragma_Placement
;
6272 -------------------------------------------
6273 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6274 -------------------------------------------
6276 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6285 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6288 elsif Nkind_In
(P
, N_Package_Specification
,
6293 -- Note: the following tests seem a little peculiar, because
6294 -- they test for bodies, but if we were in the statement part
6295 -- of the body, we would already have hit the handled statement
6296 -- sequence, so the only way we get here is by being in the
6297 -- declarative part of the body.
6299 elsif Nkind_In
(P
, N_Subprogram_Body
,
6310 Error_Pragma
("pragma% is not in declarative part or package spec");
6311 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6313 -------------------------
6314 -- Check_No_Identifier --
6315 -------------------------
6317 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6319 if Nkind
(Arg
) = N_Pragma_Argument_Association
6320 and then Chars
(Arg
) /= No_Name
6322 Error_Pragma_Arg_Ident
6323 ("pragma% does not permit identifier& here", Arg
);
6325 end Check_No_Identifier
;
6327 --------------------------
6328 -- Check_No_Identifiers --
6329 --------------------------
6331 procedure Check_No_Identifiers
is
6335 for J
in 1 .. Arg_Count
loop
6336 Check_No_Identifier
(Arg_Node
);
6339 end Check_No_Identifiers
;
6341 ------------------------
6342 -- Check_No_Link_Name --
6343 ------------------------
6345 procedure Check_No_Link_Name
is
6347 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6351 if Present
(Arg4
) then
6353 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6355 end Check_No_Link_Name
;
6357 -------------------------------
6358 -- Check_Optional_Identifier --
6359 -------------------------------
6361 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6364 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6365 and then Chars
(Arg
) /= No_Name
6367 if Chars
(Arg
) /= Id
then
6368 Error_Msg_Name_1
:= Pname
;
6369 Error_Msg_Name_2
:= Id
;
6370 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6374 end Check_Optional_Identifier
;
6376 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6378 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6379 end Check_Optional_Identifier
;
6381 -------------------------------------
6382 -- Check_Static_Boolean_Expression --
6383 -------------------------------------
6385 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6387 if Present
(Expr
) then
6388 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6390 if not Is_OK_Static_Expression
(Expr
) then
6392 ("expression of pragma % must be static", Expr
);
6395 end Check_Static_Boolean_Expression
;
6397 -----------------------------
6398 -- Check_Static_Constraint --
6399 -----------------------------
6401 -- Note: for convenience in writing this procedure, in addition to
6402 -- the officially (i.e. by spec) allowed argument which is always a
6403 -- constraint, it also allows ranges and discriminant associations.
6404 -- Above is not clear ???
6406 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6408 procedure Require_Static
(E
: Node_Id
);
6409 -- Require given expression to be static expression
6411 --------------------
6412 -- Require_Static --
6413 --------------------
6415 procedure Require_Static
(E
: Node_Id
) is
6417 if not Is_OK_Static_Expression
(E
) then
6418 Flag_Non_Static_Expr
6419 ("non-static constraint not allowed in Unchecked_Union!", E
);
6424 -- Start of processing for Check_Static_Constraint
6427 case Nkind
(Constr
) is
6428 when N_Discriminant_Association
=>
6429 Require_Static
(Expression
(Constr
));
6432 Require_Static
(Low_Bound
(Constr
));
6433 Require_Static
(High_Bound
(Constr
));
6435 when N_Attribute_Reference
=>
6436 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6437 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6439 when N_Range_Constraint
=>
6440 Check_Static_Constraint
(Range_Expression
(Constr
));
6442 when N_Index_Or_Discriminant_Constraint
=>
6446 IDC
:= First
(Constraints
(Constr
));
6447 while Present
(IDC
) loop
6448 Check_Static_Constraint
(IDC
);
6456 end Check_Static_Constraint
;
6458 --------------------------------------
6459 -- Check_Valid_Configuration_Pragma --
6460 --------------------------------------
6462 -- A configuration pragma must appear in the context clause of a
6463 -- compilation unit, and only other pragmas may precede it. Note that
6464 -- the test also allows use in a configuration pragma file.
6466 procedure Check_Valid_Configuration_Pragma
is
6468 if not Is_Configuration_Pragma
then
6469 Error_Pragma
("incorrect placement for configuration pragma%");
6471 end Check_Valid_Configuration_Pragma
;
6473 -------------------------------------
6474 -- Check_Valid_Library_Unit_Pragma --
6475 -------------------------------------
6477 procedure Check_Valid_Library_Unit_Pragma
is
6479 Parent_Node
: Node_Id
;
6480 Unit_Name
: Entity_Id
;
6481 Unit_Kind
: Node_Kind
;
6482 Unit_Node
: Node_Id
;
6483 Sindex
: Source_File_Index
;
6486 if not Is_List_Member
(N
) then
6490 Plist
:= List_Containing
(N
);
6491 Parent_Node
:= Parent
(Plist
);
6493 if Parent_Node
= Empty
then
6496 -- Case of pragma appearing after a compilation unit. In this case
6497 -- it must have an argument with the corresponding name and must
6498 -- be part of the following pragmas of its parent.
6500 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6501 if Plist
/= Pragmas_After
(Parent_Node
) then
6504 elsif Arg_Count
= 0 then
6506 ("argument required if outside compilation unit");
6509 Check_No_Identifiers
;
6510 Check_Arg_Count
(1);
6511 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6512 Unit_Kind
:= Nkind
(Unit_Node
);
6514 Analyze
(Get_Pragma_Arg
(Arg1
));
6516 if Unit_Kind
= N_Generic_Subprogram_Declaration
6517 or else Unit_Kind
= N_Subprogram_Declaration
6519 Unit_Name
:= Defining_Entity
(Unit_Node
);
6521 elsif Unit_Kind
in N_Generic_Instantiation
then
6522 Unit_Name
:= Defining_Entity
(Unit_Node
);
6525 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6528 if Chars
(Unit_Name
) /=
6529 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6532 ("pragma% argument is not current unit name", Arg1
);
6535 if Ekind
(Unit_Name
) = E_Package
6536 and then Present
(Renamed_Entity
(Unit_Name
))
6538 Error_Pragma
("pragma% not allowed for renamed package");
6542 -- Pragma appears other than after a compilation unit
6545 -- Here we check for the generic instantiation case and also
6546 -- for the case of processing a generic formal package. We
6547 -- detect these cases by noting that the Sloc on the node
6548 -- does not belong to the current compilation unit.
6550 Sindex
:= Source_Index
(Current_Sem_Unit
);
6552 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6553 Rewrite
(N
, Make_Null_Statement
(Loc
));
6556 -- If before first declaration, the pragma applies to the
6557 -- enclosing unit, and the name if present must be this name.
6559 elsif Is_Before_First_Decl
(N
, Plist
) then
6560 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6561 Unit_Kind
:= Nkind
(Unit_Node
);
6563 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6566 elsif Unit_Kind
= N_Subprogram_Body
6567 and then not Acts_As_Spec
(Unit_Node
)
6571 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6574 elsif Nkind
(Parent_Node
) = N_Package_Specification
6575 and then Plist
= Private_Declarations
(Parent_Node
)
6579 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6580 or else Nkind
(Parent_Node
) =
6581 N_Generic_Subprogram_Declaration
)
6582 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6586 elsif Arg_Count
> 0 then
6587 Analyze
(Get_Pragma_Arg
(Arg1
));
6589 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6591 ("name in pragma% must be enclosing unit", Arg1
);
6594 -- It is legal to have no argument in this context
6600 -- Error if not before first declaration. This is because a
6601 -- library unit pragma argument must be the name of a library
6602 -- unit (RM 10.1.5(7)), but the only names permitted in this
6603 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6604 -- generic subprogram declarations or generic instantiations.
6608 ("pragma% misplaced, must be before first declaration");
6612 end Check_Valid_Library_Unit_Pragma
;
6618 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6619 Clist
: constant Node_Id
:= Component_List
(Variant
);
6623 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6624 while Present
(Comp
) loop
6625 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6626 Next_Non_Pragma
(Comp
);
6630 ---------------------------
6631 -- Ensure_Aggregate_Form --
6632 ---------------------------
6634 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6635 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6636 Expr
: constant Node_Id
:= Expression
(Arg
);
6637 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6638 Comps
: List_Id
:= No_List
;
6639 Exprs
: List_Id
:= No_List
;
6640 Nam
: Name_Id
:= No_Name
;
6641 Nam_Loc
: Source_Ptr
;
6644 -- The pragma argument is in positional form:
6646 -- pragma Depends (Nam => ...)
6650 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6651 -- argument association.
6653 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6655 Nam_Loc
:= Sloc
(Arg
);
6657 -- Remove the pragma argument name as this will be captured in the
6660 Set_Chars
(Arg
, No_Name
);
6663 -- The argument is already in aggregate form, but the presence of a
6664 -- name causes this to be interpreted as named association which in
6665 -- turn must be converted into an aggregate.
6667 -- pragma Global (In_Out => (A, B, C))
6671 -- pragma Global ((In_Out => (A, B, C)))
6673 -- aggregate aggregate
6675 if Nkind
(Expr
) = N_Aggregate
then
6676 if Nam
= No_Name
then
6680 -- Do not transform a null argument into an aggregate as N_Null has
6681 -- special meaning in formal verification pragmas.
6683 elsif Nkind
(Expr
) = N_Null
then
6687 -- Everything comes from source if the original comes from source
6689 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6691 -- Positional argument is transformed into an aggregate with an
6692 -- Expressions list.
6694 if Nam
= No_Name
then
6695 Exprs
:= New_List
(Relocate_Node
(Expr
));
6697 -- An associative argument is transformed into an aggregate with
6698 -- Component_Associations.
6702 Make_Component_Association
(Loc
,
6703 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6704 Expression
=> Relocate_Node
(Expr
)));
6707 Set_Expression
(Arg
,
6708 Make_Aggregate
(Loc
,
6709 Component_Associations
=> Comps
,
6710 Expressions
=> Exprs
));
6712 -- Restore Comes_From_Source default
6714 Set_Comes_From_Source_Default
(CFSD
);
6715 end Ensure_Aggregate_Form
;
6721 procedure Error_Pragma
(Msg
: String) is
6723 Error_Msg_Name_1
:= Pname
;
6724 Error_Msg_N
(Fix_Error
(Msg
), N
);
6728 ----------------------
6729 -- Error_Pragma_Arg --
6730 ----------------------
6732 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6734 Error_Msg_Name_1
:= Pname
;
6735 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6737 end Error_Pragma_Arg
;
6739 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6741 Error_Msg_Name_1
:= Pname
;
6742 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6743 Error_Pragma_Arg
(Msg2
, Arg
);
6744 end Error_Pragma_Arg
;
6746 ----------------------------
6747 -- Error_Pragma_Arg_Ident --
6748 ----------------------------
6750 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6752 Error_Msg_Name_1
:= Pname
;
6753 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6755 end Error_Pragma_Arg_Ident
;
6757 ----------------------
6758 -- Error_Pragma_Ref --
6759 ----------------------
6761 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6763 Error_Msg_Name_1
:= Pname
;
6764 Error_Msg_Sloc
:= Sloc
(Ref
);
6765 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6767 end Error_Pragma_Ref
;
6769 ------------------------
6770 -- Find_Lib_Unit_Name --
6771 ------------------------
6773 function Find_Lib_Unit_Name
return Entity_Id
is
6775 -- Return inner compilation unit entity, for case of nested
6776 -- categorization pragmas. This happens in generic unit.
6778 if Nkind
(Parent
(N
)) = N_Package_Specification
6779 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6781 return Defining_Entity
(Parent
(N
));
6783 return Current_Scope
;
6785 end Find_Lib_Unit_Name
;
6787 ----------------------------
6788 -- Find_Program_Unit_Name --
6789 ----------------------------
6791 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6792 Unit_Name
: Entity_Id
;
6793 Unit_Kind
: Node_Kind
;
6794 P
: constant Node_Id
:= Parent
(N
);
6797 if Nkind
(P
) = N_Compilation_Unit
then
6798 Unit_Kind
:= Nkind
(Unit
(P
));
6800 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6801 N_Package_Declaration
)
6802 or else Unit_Kind
in N_Generic_Declaration
6804 Unit_Name
:= Defining_Entity
(Unit
(P
));
6806 if Chars
(Id
) = Chars
(Unit_Name
) then
6807 Set_Entity
(Id
, Unit_Name
);
6808 Set_Etype
(Id
, Etype
(Unit_Name
));
6810 Set_Etype
(Id
, Any_Type
);
6812 ("cannot find program unit referenced by pragma%");
6816 Set_Etype
(Id
, Any_Type
);
6817 Error_Pragma
("pragma% inapplicable to this unit");
6823 end Find_Program_Unit_Name
;
6825 -----------------------------------------
6826 -- Find_Unique_Parameterless_Procedure --
6827 -----------------------------------------
6829 function Find_Unique_Parameterless_Procedure
6831 Arg
: Node_Id
) return Entity_Id
6833 Proc
: Entity_Id
:= Empty
;
6836 -- The body of this procedure needs some comments ???
6838 if not Is_Entity_Name
(Name
) then
6840 ("argument of pragma% must be entity name", Arg
);
6842 elsif not Is_Overloaded
(Name
) then
6843 Proc
:= Entity
(Name
);
6845 if Ekind
(Proc
) /= E_Procedure
6846 or else Present
(First_Formal
(Proc
))
6849 ("argument of pragma% must be parameterless procedure", Arg
);
6854 Found
: Boolean := False;
6856 Index
: Interp_Index
;
6859 Get_First_Interp
(Name
, Index
, It
);
6860 while Present
(It
.Nam
) loop
6863 if Ekind
(Proc
) = E_Procedure
6864 and then No
(First_Formal
(Proc
))
6868 Set_Entity
(Name
, Proc
);
6869 Set_Is_Overloaded
(Name
, False);
6872 ("ambiguous handler name for pragma% ", Arg
);
6876 Get_Next_Interp
(Index
, It
);
6881 ("argument of pragma% must be parameterless procedure",
6884 Proc
:= Entity
(Name
);
6890 end Find_Unique_Parameterless_Procedure
;
6896 function Fix_Error
(Msg
: String) return String is
6897 Res
: String (Msg
'Range) := Msg
;
6898 Res_Last
: Natural := Msg
'Last;
6902 -- If we have a rewriting of another pragma, go to that pragma
6904 if Is_Rewrite_Substitution
(N
)
6905 and then Nkind
(Original_Node
(N
)) = N_Pragma
6907 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6910 -- Case where pragma comes from an aspect specification
6912 if From_Aspect_Specification
(N
) then
6914 -- Change appearence of "pragma" in message to "aspect"
6917 while J
<= Res_Last
- 5 loop
6918 if Res
(J
.. J
+ 5) = "pragma" then
6919 Res
(J
.. J
+ 5) := "aspect";
6927 -- Change "argument of" at start of message to "entity for"
6930 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6932 Res
(Res
'First .. Res
'First + 9) := "entity for";
6933 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6934 Res
(Res
'First + 11 .. Res_Last
);
6935 Res_Last
:= Res_Last
- 1;
6938 -- Change "argument" at start of message to "entity"
6941 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6943 Res
(Res
'First .. Res
'First + 5) := "entity";
6944 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6945 Res
(Res
'First + 8 .. Res_Last
);
6946 Res_Last
:= Res_Last
- 2;
6949 -- Get name from corresponding aspect
6951 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6954 -- Return possibly modified message
6956 return Res
(Res
'First .. Res_Last
);
6959 -------------------------
6960 -- Gather_Associations --
6961 -------------------------
6963 procedure Gather_Associations
6965 Args
: out Args_List
)
6970 -- Initialize all parameters to Empty
6972 for J
in Args
'Range loop
6976 -- That's all we have to do if there are no argument associations
6978 if No
(Pragma_Argument_Associations
(N
)) then
6982 -- Otherwise first deal with any positional parameters present
6984 Arg
:= First
(Pragma_Argument_Associations
(N
));
6985 for Index
in Args
'Range loop
6986 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6987 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6991 -- Positional parameters all processed, if any left, then we
6992 -- have too many positional parameters.
6994 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6996 ("too many positional associations for pragma%", Arg
);
6999 -- Process named parameters if any are present
7001 while Present
(Arg
) loop
7002 if Chars
(Arg
) = No_Name
then
7004 ("positional association cannot follow named association",
7008 for Index
in Names
'Range loop
7009 if Names
(Index
) = Chars
(Arg
) then
7010 if Present
(Args
(Index
)) then
7012 ("duplicate argument association for pragma%", Arg
);
7014 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7019 if Index
= Names
'Last then
7020 Error_Msg_Name_1
:= Pname
;
7021 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7023 -- Check for possible misspelling
7025 for Index1
in Names
'Range loop
7026 if Is_Bad_Spelling_Of
7027 (Chars
(Arg
), Names
(Index1
))
7029 Error_Msg_Name_1
:= Names
(Index1
);
7030 Error_Msg_N
-- CODEFIX
7031 ("\possible misspelling of%", Arg
);
7043 end Gather_Associations
;
7049 procedure GNAT_Pragma
is
7051 -- We need to check the No_Implementation_Pragmas restriction for
7052 -- the case of a pragma from source. Note that the case of aspects
7053 -- generating corresponding pragmas marks these pragmas as not being
7054 -- from source, so this test also catches that case.
7056 if Comes_From_Source
(N
) then
7057 Check_Restriction
(No_Implementation_Pragmas
, N
);
7061 --------------------------
7062 -- Is_Before_First_Decl --
7063 --------------------------
7065 function Is_Before_First_Decl
7066 (Pragma_Node
: Node_Id
;
7067 Decls
: List_Id
) return Boolean
7069 Item
: Node_Id
:= First
(Decls
);
7072 -- Only other pragmas can come before this pragma
7075 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
7078 elsif Item
= Pragma_Node
then
7084 end Is_Before_First_Decl
;
7086 -----------------------------
7087 -- Is_Configuration_Pragma --
7088 -----------------------------
7090 -- A configuration pragma must appear in the context clause of a
7091 -- compilation unit, and only other pragmas may precede it. Note that
7092 -- the test below also permits use in a configuration pragma file.
7094 function Is_Configuration_Pragma
return Boolean is
7095 Lis
: constant List_Id
:= List_Containing
(N
);
7096 Par
: constant Node_Id
:= Parent
(N
);
7100 -- If no parent, then we are in the configuration pragma file,
7101 -- so the placement is definitely appropriate.
7106 -- Otherwise we must be in the context clause of a compilation unit
7107 -- and the only thing allowed before us in the context list is more
7108 -- configuration pragmas.
7110 elsif Nkind
(Par
) = N_Compilation_Unit
7111 and then Context_Items
(Par
) = Lis
7118 elsif Nkind
(Prg
) /= N_Pragma
then
7128 end Is_Configuration_Pragma
;
7130 --------------------------
7131 -- Is_In_Context_Clause --
7132 --------------------------
7134 function Is_In_Context_Clause
return Boolean is
7136 Parent_Node
: Node_Id
;
7139 if not Is_List_Member
(N
) then
7143 Plist
:= List_Containing
(N
);
7144 Parent_Node
:= Parent
(Plist
);
7146 if Parent_Node
= Empty
7147 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7148 or else Context_Items
(Parent_Node
) /= Plist
7155 end Is_In_Context_Clause
;
7157 ---------------------------------
7158 -- Is_Static_String_Expression --
7159 ---------------------------------
7161 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7162 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7163 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7166 Analyze_And_Resolve
(Argx
);
7168 -- Special case Ada 83, where the expression will never be static,
7169 -- but we will return true if we had a string literal to start with.
7171 if Ada_Version
= Ada_83
then
7174 -- Normal case, true only if we end up with a string literal that
7175 -- is marked as being the result of evaluating a static expression.
7178 return Is_OK_Static_Expression
(Argx
)
7179 and then Nkind
(Argx
) = N_String_Literal
;
7182 end Is_Static_String_Expression
;
7184 ----------------------
7185 -- Pragma_Misplaced --
7186 ----------------------
7188 procedure Pragma_Misplaced
is
7190 Error_Pragma
("incorrect placement of pragma%");
7191 end Pragma_Misplaced
;
7193 ------------------------------------------------
7194 -- Process_Atomic_Independent_Shared_Volatile --
7195 ------------------------------------------------
7197 procedure Process_Atomic_Independent_Shared_Volatile
is
7198 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
7199 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7201 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7202 -- Appropriately set flags on the given entity (either an array or
7203 -- record component, or an object declaration) according to the
7206 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7207 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7208 -- no explicit alignment was given, set alignment to unknown, since
7209 -- back end knows what the alignment requirements are for atomic and
7210 -- full access arrays. Note: this is necessary for derived types.
7212 -------------------------
7213 -- Check_VFA_Conflicts --
7214 -------------------------
7216 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7220 VFA_And_Atomic
: Boolean := False;
7221 -- Set True if atomic component present
7223 VFA_And_Aliased
: Boolean := False;
7224 -- Set True if aliased component present
7227 -- Fetch the type in case we are dealing with an object or
7230 if Is_Type
(Ent
) then
7233 pragma Assert
(Is_Object
(Ent
)
7235 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7240 -- Check Atomic and VFA used together
7242 if Prag_Id
= Pragma_Volatile_Full_Access
7243 or else Is_Volatile_Full_Access
(Ent
)
7245 if Prag_Id
= Pragma_Atomic
7246 or else Prag_Id
= Pragma_Shared
7247 or else Is_Atomic
(Ent
)
7249 VFA_And_Atomic
:= True;
7251 elsif Is_Array_Type
(Typ
) then
7252 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7254 -- Note: Has_Atomic_Components is not used below, as this flag
7255 -- represents the pragma of the same name, Atomic_Components,
7256 -- which only applies to arrays.
7258 elsif Is_Record_Type
(Typ
) then
7259 -- Attributes cannot be applied to discriminants, only
7260 -- regular record components.
7262 Comp
:= First_Component
(Typ
);
7263 while Present
(Comp
) loop
7265 or else Is_Atomic
(Typ
)
7267 VFA_And_Atomic
:= True;
7272 Next_Component
(Comp
);
7276 if VFA_And_Atomic
then
7278 ("cannot have Volatile_Full_Access and Atomic for same "
7283 -- Check for the application of VFA to an entity that has aliased
7286 if Prag_Id
= Pragma_Volatile_Full_Access
then
7287 if Is_Array_Type
(Typ
)
7288 and then Has_Aliased_Components
(Typ
)
7290 VFA_And_Aliased
:= True;
7292 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7293 -- and Has_Independent_Components, applies only to arrays.
7294 -- However, this flag does not have a corresponding pragma, so
7295 -- perhaps it should be possible to apply it to record types as
7296 -- well. Should this be done ???
7298 elsif Is_Record_Type
(Typ
) then
7299 -- It is possible to have an aliased discriminant, so they
7300 -- must be checked along with normal components.
7302 Comp
:= First_Component_Or_Discriminant
(Typ
);
7303 while Present
(Comp
) loop
7304 if Is_Aliased
(Comp
)
7305 or else Is_Aliased
(Etype
(Comp
))
7307 VFA_And_Aliased
:= True;
7308 Check_SPARK_05_Restriction
7309 ("aliased is not allowed", Comp
);
7314 Next_Component_Or_Discriminant
(Comp
);
7318 if VFA_And_Aliased
then
7320 ("cannot apply Volatile_Full_Access (aliased component "
7324 end Check_VFA_Conflicts
;
7326 ------------------------------
7327 -- Mark_Component_Or_Object --
7328 ------------------------------
7330 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7332 if Prag_Id
= Pragma_Atomic
7333 or else Prag_Id
= Pragma_Shared
7334 or else Prag_Id
= Pragma_Volatile_Full_Access
7336 if Prag_Id
= Pragma_Volatile_Full_Access
then
7337 Set_Is_Volatile_Full_Access
(Ent
);
7339 Set_Is_Atomic
(Ent
);
7342 -- If the object declaration has an explicit initialization, a
7343 -- temporary may have to be created to hold the expression, to
7344 -- ensure that access to the object remains atomic.
7346 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7347 and then Present
(Expression
(Parent
(Ent
)))
7349 Set_Has_Delayed_Freeze
(Ent
);
7353 -- Atomic/Shared/Volatile_Full_Access imply Independent
7355 if Prag_Id
/= Pragma_Volatile
then
7356 Set_Is_Independent
(Ent
);
7358 if Prag_Id
= Pragma_Independent
then
7359 Record_Independence_Check
(N
, Ent
);
7363 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7365 if Prag_Id
/= Pragma_Independent
then
7366 Set_Is_Volatile
(Ent
);
7367 Set_Treat_As_Volatile
(Ent
);
7369 end Mark_Component_Or_Object
;
7371 --------------------
7372 -- Set_Atomic_VFA --
7373 --------------------
7375 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7377 if Prag_Id
= Pragma_Volatile_Full_Access
then
7378 Set_Is_Volatile_Full_Access
(Ent
);
7380 Set_Is_Atomic
(Ent
);
7383 if not Has_Alignment_Clause
(Ent
) then
7384 Set_Alignment
(Ent
, Uint_0
);
7394 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7397 Check_Ada_83_Warning
;
7398 Check_No_Identifiers
;
7399 Check_Arg_Count
(1);
7400 Check_Arg_Is_Local_Name
(Arg1
);
7401 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7403 if Etype
(E_Arg
) = Any_Type
then
7407 E
:= Entity
(E_Arg
);
7409 -- A pragma that applies to a Ghost entity becomes Ghost for the
7410 -- purposes of legality checks and removal of ignored Ghost code.
7412 Mark_Ghost_Pragma
(N
, E
);
7414 -- Check duplicate before we chain ourselves
7416 Check_Duplicate_Pragma
(E
);
7418 -- Check appropriateness of the entity
7420 Decl
:= Declaration_Node
(E
);
7422 -- Deal with the case where the pragma/attribute is applied to a type
7425 if Rep_Item_Too_Early
(E
, N
)
7426 or else Rep_Item_Too_Late
(E
, N
)
7430 Check_First_Subtype
(Arg1
);
7433 -- Attribute belongs on the base type. If the view of the type is
7434 -- currently private, it also belongs on the underlying type.
7436 if Prag_Id
= Pragma_Atomic
7437 or else Prag_Id
= Pragma_Shared
7438 or else Prag_Id
= Pragma_Volatile_Full_Access
7441 Set_Atomic_VFA
(Base_Type
(E
));
7442 Set_Atomic_VFA
(Underlying_Type
(E
));
7445 -- Atomic/Shared/Volatile_Full_Access imply Independent
7447 if Prag_Id
/= Pragma_Volatile
then
7448 Set_Is_Independent
(E
);
7449 Set_Is_Independent
(Base_Type
(E
));
7450 Set_Is_Independent
(Underlying_Type
(E
));
7452 if Prag_Id
= Pragma_Independent
then
7453 Record_Independence_Check
(N
, Base_Type
(E
));
7457 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7459 if Prag_Id
/= Pragma_Independent
then
7460 Set_Is_Volatile
(E
);
7461 Set_Is_Volatile
(Base_Type
(E
));
7462 Set_Is_Volatile
(Underlying_Type
(E
));
7464 Set_Treat_As_Volatile
(E
);
7465 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7468 -- Apply Volatile to the composite type's individual components,
7471 if Prag_Id
= Pragma_Volatile
7472 and then Is_Record_Type
(Etype
(E
))
7477 Comp
:= First_Component
(E
);
7478 while Present
(Comp
) loop
7479 Mark_Component_Or_Object
(Comp
);
7481 Next_Component
(Comp
);
7486 -- Deal with the case where the pragma/attribute applies to a
7487 -- component or object declaration.
7489 elsif Nkind
(Decl
) = N_Object_Declaration
7490 or else (Nkind
(Decl
) = N_Component_Declaration
7491 and then Original_Record_Component
(E
) = E
)
7493 if Rep_Item_Too_Late
(E
, N
) then
7497 Mark_Component_Or_Object
(E
);
7499 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7502 -- Perform the checks needed to assure the proper use of the GNAT
7503 -- pragma Volatile_Full_Access.
7505 Check_VFA_Conflicts
(E
);
7507 -- The following check is only relevant when SPARK_Mode is on as
7508 -- this is not a standard Ada legality rule. Pragma Volatile can
7509 -- only apply to a full type declaration or an object declaration
7510 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7511 -- untagged derived types that are rewritten as subtypes of their
7512 -- respective root types.
7515 and then Prag_Id
= Pragma_Volatile
7516 and then not Nkind_In
(Original_Node
(Decl
),
7517 N_Full_Type_Declaration
,
7518 N_Object_Declaration
,
7519 N_Single_Protected_Declaration
,
7520 N_Single_Task_Declaration
)
7523 ("argument of pragma % must denote a full type or object "
7524 & "declaration", Arg1
);
7526 end Process_Atomic_Independent_Shared_Volatile
;
7528 -------------------------------------------
7529 -- Process_Compile_Time_Warning_Or_Error --
7530 -------------------------------------------
7532 procedure Process_Compile_Time_Warning_Or_Error
is
7533 Validation_Needed
: Boolean := False;
7535 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7536 -- Tree visitor that checks if N is an attribute reference that can
7537 -- be statically computed by the back end. Validation_Needed is set
7538 -- to True if found.
7544 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7546 if Nkind
(N
) = N_Attribute_Reference
7547 and then Is_Entity_Name
(Prefix
(N
))
7550 Attr_Id
: constant Attribute_Id
:=
7551 Get_Attribute_Id
(Attribute_Name
(N
));
7553 if Attr_Id
= Attribute_Alignment
7554 or else Attr_Id
= Attribute_Size
7556 Validation_Needed
:= True;
7564 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7568 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7570 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7573 -- In GNATprove mode, pragmas Compile_Time_Error and
7574 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7575 -- same information as the compiler (in particular regarding size of
7576 -- objects decided in gigi) so it makes no sense to issue an error or
7577 -- warning in GNATprove.
7579 if GNATprove_Mode
then
7580 Rewrite
(N
, Make_Null_Statement
(Loc
));
7584 Check_Arg_Count
(2);
7585 Check_No_Identifiers
;
7586 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7587 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7589 if Compile_Time_Known_Value
(Arg1x
) then
7590 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7592 -- Register the expression for its validation after the back end has
7593 -- been called if it has occurrences of attributes Size or Alignment
7594 -- (because they may be statically computed by the back end and hence
7595 -- the whole expression needs to be reevaluated).
7598 Check_Expression
(Arg1x
);
7600 if Validation_Needed
then
7601 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7604 end Process_Compile_Time_Warning_Or_Error
;
7606 ------------------------
7607 -- Process_Convention --
7608 ------------------------
7610 procedure Process_Convention
7611 (C
: out Convention_Id
;
7612 Ent
: out Entity_Id
)
7616 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7617 -- Called if we have more than one Export/Import/Convention pragma.
7618 -- This is generally illegal, but we have a special case of allowing
7619 -- Import and Interface to coexist if they specify the convention in
7620 -- a consistent manner. We are allowed to do this, since Interface is
7621 -- an implementation defined pragma, and we choose to do it since we
7622 -- know Rational allows this combination. S is the entity id of the
7623 -- subprogram in question. This procedure also sets the special flag
7624 -- Import_Interface_Present in both pragmas in the case where we do
7625 -- have matching Import and Interface pragmas.
7627 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7628 -- Set convention in entity E, and also flag that the entity has a
7629 -- convention pragma. If entity is for a private or incomplete type,
7630 -- also set convention and flag on underlying type. This procedure
7631 -- also deals with the special case of C_Pass_By_Copy convention,
7632 -- and error checks for inappropriate convention specification.
7634 -------------------------------
7635 -- Diagnose_Multiple_Pragmas --
7636 -------------------------------
7638 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7639 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7643 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7644 -- Decl is a pragma node. This function returns True if this
7645 -- pragma has a first argument that is an identifier with a
7646 -- Chars field corresponding to the Convention_Id C.
7648 function Same_Name
(Decl
: Node_Id
) return Boolean;
7649 -- Decl is a pragma node. This function returns True if this
7650 -- pragma has a second argument that is an identifier with a
7651 -- Chars field that matches the Chars of the current subprogram.
7653 ---------------------
7654 -- Same_Convention --
7655 ---------------------
7657 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7658 Arg1
: constant Node_Id
:=
7659 First
(Pragma_Argument_Associations
(Decl
));
7662 if Present
(Arg1
) then
7664 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7666 if Nkind
(Arg
) = N_Identifier
7667 and then Is_Convention_Name
(Chars
(Arg
))
7668 and then Get_Convention_Id
(Chars
(Arg
)) = C
7676 end Same_Convention
;
7682 function Same_Name
(Decl
: Node_Id
) return Boolean is
7683 Arg1
: constant Node_Id
:=
7684 First
(Pragma_Argument_Associations
(Decl
));
7692 Arg2
:= Next
(Arg1
);
7699 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7701 if Nkind
(Arg
) = N_Identifier
7702 and then Chars
(Arg
) = Chars
(S
)
7711 -- Start of processing for Diagnose_Multiple_Pragmas
7716 -- Definitely give message if we have Convention/Export here
7718 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7721 -- If we have an Import or Export, scan back from pragma to
7722 -- find any previous pragma applying to the same procedure.
7723 -- The scan will be terminated by the start of the list, or
7724 -- hitting the subprogram declaration. This won't allow one
7725 -- pragma to appear in the public part and one in the private
7726 -- part, but that seems very unlikely in practice.
7730 while Present
(Decl
) and then Decl
/= Pdec
loop
7732 -- Look for pragma with same name as us
7734 if Nkind
(Decl
) = N_Pragma
7735 and then Same_Name
(Decl
)
7737 -- Give error if same as our pragma or Export/Convention
7739 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7742 Pragma_Name_Unmapped
(N
))
7746 -- Case of Import/Interface or the other way round
7748 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7749 Name_Interface
, Name_Import
)
7751 -- Here we know that we have Import and Interface. It
7752 -- doesn't matter which way round they are. See if
7753 -- they specify the same convention. If so, all OK,
7754 -- and set special flags to stop other messages
7756 if Same_Convention
(Decl
) then
7757 Set_Import_Interface_Present
(N
);
7758 Set_Import_Interface_Present
(Decl
);
7761 -- If different conventions, special message
7764 Error_Msg_Sloc
:= Sloc
(Decl
);
7766 ("convention differs from that given#", Arg1
);
7776 -- Give message if needed if we fall through those tests
7777 -- except on Relaxed_RM_Semantics where we let go: either this
7778 -- is a case accepted/ignored by other Ada compilers (e.g.
7779 -- a mix of Convention and Import), or another error will be
7780 -- generated later (e.g. using both Import and Export).
7782 if Err
and not Relaxed_RM_Semantics
then
7784 ("at most one Convention/Export/Import pragma is allowed",
7787 end Diagnose_Multiple_Pragmas
;
7789 --------------------------------
7790 -- Set_Convention_From_Pragma --
7791 --------------------------------
7793 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7795 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7796 -- for an overridden dispatching operation. Technically this is
7797 -- an amendment and should only be done in Ada 2005 mode. However,
7798 -- this is clearly a mistake, since the problem that is addressed
7799 -- by this AI is that there is a clear gap in the RM.
7801 if Is_Dispatching_Operation
(E
)
7802 and then Present
(Overridden_Operation
(E
))
7803 and then C
/= Convention
(Overridden_Operation
(E
))
7806 ("cannot change convention for overridden dispatching "
7807 & "operation", Arg1
);
7810 -- Special checks for Convention_Stdcall
7812 if C
= Convention_Stdcall
then
7814 -- A dispatching call is not allowed. A dispatching subprogram
7815 -- cannot be used to interface to the Win32 API, so in fact
7816 -- this check does not impose any effective restriction.
7818 if Is_Dispatching_Operation
(E
) then
7819 Error_Msg_Sloc
:= Sloc
(E
);
7821 -- Note: make this unconditional so that if there is more
7822 -- than one call to which the pragma applies, we get a
7823 -- message for each call. Also don't use Error_Pragma,
7824 -- so that we get multiple messages.
7827 ("dispatching subprogram# cannot use Stdcall convention!",
7830 -- Several allowed cases
7832 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7836 or else Ekind
(E
) = E_Variable
7838 -- A component as well. The entity does not have its Ekind
7839 -- set until the enclosing record declaration is fully
7842 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7844 -- An access to subprogram is also allowed
7848 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7850 -- Allow internal call to set convention of subprogram type
7852 or else Ekind
(E
) = E_Subprogram_Type
7858 ("second argument of pragma% must be subprogram (type)",
7863 -- Set the convention
7865 Set_Convention
(E
, C
);
7866 Set_Has_Convention_Pragma
(E
);
7868 -- For the case of a record base type, also set the convention of
7869 -- any anonymous access types declared in the record which do not
7870 -- currently have a specified convention.
7872 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7877 Comp
:= First_Component
(E
);
7878 while Present
(Comp
) loop
7879 if Present
(Etype
(Comp
))
7880 and then Ekind_In
(Etype
(Comp
),
7881 E_Anonymous_Access_Type
,
7882 E_Anonymous_Access_Subprogram_Type
)
7883 and then not Has_Convention_Pragma
(Comp
)
7885 Set_Convention
(Comp
, C
);
7888 Next_Component
(Comp
);
7893 -- Deal with incomplete/private type case, where underlying type
7894 -- is available, so set convention of that underlying type.
7896 if Is_Incomplete_Or_Private_Type
(E
)
7897 and then Present
(Underlying_Type
(E
))
7899 Set_Convention
(Underlying_Type
(E
), C
);
7900 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7903 -- A class-wide type should inherit the convention of the specific
7904 -- root type (although this isn't specified clearly by the RM).
7906 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7907 Set_Convention
(Class_Wide_Type
(E
), C
);
7910 -- If the entity is a record type, then check for special case of
7911 -- C_Pass_By_Copy, which is treated the same as C except that the
7912 -- special record flag is set. This convention is only permitted
7913 -- on record types (see AI95-00131).
7915 if Cname
= Name_C_Pass_By_Copy
then
7916 if Is_Record_Type
(E
) then
7917 Set_C_Pass_By_Copy
(Base_Type
(E
));
7918 elsif Is_Incomplete_Or_Private_Type
(E
)
7919 and then Is_Record_Type
(Underlying_Type
(E
))
7921 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7924 ("C_Pass_By_Copy convention allowed only for record type",
7929 -- If the entity is a derived boolean type, check for the special
7930 -- case of convention C, C++, or Fortran, where we consider any
7931 -- nonzero value to represent true.
7933 if Is_Discrete_Type
(E
)
7934 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7940 C
= Convention_Fortran
)
7942 Set_Nonzero_Is_True
(Base_Type
(E
));
7944 end Set_Convention_From_Pragma
;
7948 Comp_Unit
: Unit_Number_Type
;
7953 -- Start of processing for Process_Convention
7956 Check_At_Least_N_Arguments
(2);
7957 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7958 Check_Arg_Is_Identifier
(Arg1
);
7959 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7961 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7962 -- tested again below to set the critical flag).
7964 if Cname
= Name_C_Pass_By_Copy
then
7967 -- Otherwise we must have something in the standard convention list
7969 elsif Is_Convention_Name
(Cname
) then
7970 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7972 -- Otherwise warn on unrecognized convention
7975 if Warn_On_Export_Import
then
7977 ("??unrecognized convention name, C assumed",
7978 Get_Pragma_Arg
(Arg1
));
7984 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7985 Check_Arg_Is_Local_Name
(Arg2
);
7987 Id
:= Get_Pragma_Arg
(Arg2
);
7990 if not Is_Entity_Name
(Id
) then
7991 Error_Pragma_Arg
("entity name required", Arg2
);
7996 -- Set entity to return
8000 -- Ada_Pass_By_Copy special checking
8002 if C
= Convention_Ada_Pass_By_Copy
then
8003 if not Is_First_Subtype
(E
) then
8005 ("convention `Ada_Pass_By_Copy` only allowed for types",
8009 if Is_By_Reference_Type
(E
) then
8011 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8015 -- Ada_Pass_By_Reference special checking
8017 elsif C
= Convention_Ada_Pass_By_Reference
then
8018 if not Is_First_Subtype
(E
) then
8020 ("convention `Ada_Pass_By_Reference` only allowed for types",
8024 if Is_By_Copy_Type
(E
) then
8026 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8031 -- Go to renamed subprogram if present, since convention applies to
8032 -- the actual renamed entity, not to the renaming entity. If the
8033 -- subprogram is inherited, go to parent subprogram.
8035 if Is_Subprogram
(E
)
8036 and then Present
(Alias
(E
))
8038 if Nkind
(Parent
(Declaration_Node
(E
))) =
8039 N_Subprogram_Renaming_Declaration
8041 if Scope
(E
) /= Scope
(Alias
(E
)) then
8043 ("cannot apply pragma% to non-local entity&#", E
);
8048 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
8049 N_Private_Extension_Declaration
)
8050 and then Scope
(E
) = Scope
(Alias
(E
))
8054 -- Return the parent subprogram the entity was inherited from
8060 -- Check that we are not applying this to a specless body. Relax this
8061 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8063 if Is_Subprogram
(E
)
8064 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8065 and then not Relaxed_RM_Semantics
8068 ("pragma% requires separate spec and must come before body");
8071 -- Check that we are not applying this to a named constant
8073 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
8074 Error_Msg_Name_1
:= Pname
;
8076 ("cannot apply pragma% to named constant!",
8077 Get_Pragma_Arg
(Arg2
));
8079 ("\supply appropriate type for&!", Arg2
);
8082 if Ekind
(E
) = E_Enumeration_Literal
then
8083 Error_Pragma
("enumeration literal not allowed for pragma%");
8086 -- Check for rep item appearing too early or too late
8088 if Etype
(E
) = Any_Type
8089 or else Rep_Item_Too_Early
(E
, N
)
8093 elsif Present
(Underlying_Type
(E
)) then
8094 E
:= Underlying_Type
(E
);
8097 if Rep_Item_Too_Late
(E
, N
) then
8101 if Has_Convention_Pragma
(E
) then
8102 Diagnose_Multiple_Pragmas
(E
);
8104 elsif Convention
(E
) = Convention_Protected
8105 or else Ekind
(Scope
(E
)) = E_Protected_Type
8108 ("a protected operation cannot be given a different convention",
8112 -- For Intrinsic, a subprogram is required
8114 if C
= Convention_Intrinsic
8115 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8117 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8119 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8121 ("second argument of pragma% must be a subprogram", Arg2
);
8125 -- Deal with non-subprogram cases
8127 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8128 Set_Convention_From_Pragma
(E
);
8132 -- The pragma must apply to a first subtype, but it can also
8133 -- apply to a generic type in a generic formal part, in which
8134 -- case it will also appear in the corresponding instance.
8136 if Is_Generic_Type
(E
) or else In_Instance
then
8139 Check_First_Subtype
(Arg2
);
8142 Set_Convention_From_Pragma
(Base_Type
(E
));
8144 -- For access subprograms, we must set the convention on the
8145 -- internally generated directly designated type as well.
8147 if Ekind
(E
) = E_Access_Subprogram_Type
then
8148 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8152 -- For the subprogram case, set proper convention for all homonyms
8153 -- in same scope and the same declarative part, i.e. the same
8154 -- compilation unit.
8157 Comp_Unit
:= Get_Source_Unit
(E
);
8158 Set_Convention_From_Pragma
(E
);
8160 -- Treat a pragma Import as an implicit body, and pragma import
8161 -- as implicit reference (for navigation in GPS).
8163 if Prag_Id
= Pragma_Import
then
8164 Generate_Reference
(E
, Id
, 'b');
8166 -- For exported entities we restrict the generation of references
8167 -- to entities exported to foreign languages since entities
8168 -- exported to Ada do not provide further information to GPS and
8169 -- add undesired references to the output of the gnatxref tool.
8171 elsif Prag_Id
= Pragma_Export
8172 and then Convention
(E
) /= Convention_Ada
8174 Generate_Reference
(E
, Id
, 'i');
8177 -- If the pragma comes from an aspect, it only applies to the
8178 -- given entity, not its homonyms.
8180 if From_Aspect_Specification
(N
) then
8181 if C
= Convention_Intrinsic
8182 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8184 if Is_Fixed_Point_Type
(Etype
(Ent
))
8185 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8186 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8189 ("no intrinsic operator available for this fixed-point "
8192 ("\use expression functions with the desired "
8193 & "conversions made explicit", N
);
8200 -- Otherwise Loop through the homonyms of the pragma argument's
8201 -- entity, an apply convention to those in the current scope.
8207 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8209 -- Ignore entry for which convention is already set
8211 if Has_Convention_Pragma
(E1
) then
8215 if Is_Subprogram
(E1
)
8216 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8218 and then not Relaxed_RM_Semantics
8220 Set_Has_Completion
(E
); -- to prevent cascaded error
8222 ("pragma% requires separate spec and must come before "
8226 -- Do not set the pragma on inherited operations or on formal
8229 if Comes_From_Source
(E1
)
8230 and then Comp_Unit
= Get_Source_Unit
(E1
)
8231 and then not Is_Formal_Subprogram
(E1
)
8232 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8233 N_Full_Type_Declaration
8235 if Present
(Alias
(E1
))
8236 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8239 ("cannot apply pragma% to non-local entity& declared#",
8243 Set_Convention_From_Pragma
(E1
);
8245 if Prag_Id
= Pragma_Import
then
8246 Generate_Reference
(E1
, Id
, 'b');
8254 end Process_Convention
;
8256 ----------------------------------------
8257 -- Process_Disable_Enable_Atomic_Sync --
8258 ----------------------------------------
8260 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8262 Check_No_Identifiers
;
8263 Check_At_Most_N_Arguments
(1);
8265 -- Modeled internally as
8266 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8271 Pragma_Argument_Associations
=> New_List
(
8272 Make_Pragma_Argument_Association
(Loc
,
8274 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8276 if Present
(Arg1
) then
8277 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8281 end Process_Disable_Enable_Atomic_Sync
;
8283 -------------------------------------------------
8284 -- Process_Extended_Import_Export_Internal_Arg --
8285 -------------------------------------------------
8287 procedure Process_Extended_Import_Export_Internal_Arg
8288 (Arg_Internal
: Node_Id
:= Empty
)
8291 if No
(Arg_Internal
) then
8292 Error_Pragma
("Internal parameter required for pragma%");
8295 if Nkind
(Arg_Internal
) = N_Identifier
then
8298 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8299 and then (Prag_Id
= Pragma_Import_Function
8301 Prag_Id
= Pragma_Export_Function
)
8307 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8310 Check_Arg_Is_Local_Name
(Arg_Internal
);
8311 end Process_Extended_Import_Export_Internal_Arg
;
8313 --------------------------------------------------
8314 -- Process_Extended_Import_Export_Object_Pragma --
8315 --------------------------------------------------
8317 procedure Process_Extended_Import_Export_Object_Pragma
8318 (Arg_Internal
: Node_Id
;
8319 Arg_External
: Node_Id
;
8325 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8326 Def_Id
:= Entity
(Arg_Internal
);
8328 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8330 ("pragma% must designate an object", Arg_Internal
);
8333 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8335 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8338 ("previous Common/Psect_Object applies, pragma % not permitted",
8342 if Rep_Item_Too_Late
(Def_Id
, N
) then
8346 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8348 if Present
(Arg_Size
) then
8349 Check_Arg_Is_External_Name
(Arg_Size
);
8352 -- Export_Object case
8354 if Prag_Id
= Pragma_Export_Object
then
8355 if not Is_Library_Level_Entity
(Def_Id
) then
8357 ("argument for pragma% must be library level entity",
8361 if Ekind
(Current_Scope
) = E_Generic_Package
then
8362 Error_Pragma
("pragma& cannot appear in a generic unit");
8365 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8367 ("exported object must have compile time known size",
8371 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8372 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8374 Set_Exported
(Def_Id
, Arg_Internal
);
8377 -- Import_Object case
8380 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8382 ("cannot use pragma% for task/protected object",
8386 if Ekind
(Def_Id
) = E_Constant
then
8388 ("cannot import a constant", Arg_Internal
);
8391 if Warn_On_Export_Import
8392 and then Has_Discriminants
(Etype
(Def_Id
))
8395 ("imported value must be initialized??", Arg_Internal
);
8398 if Warn_On_Export_Import
8399 and then Is_Access_Type
(Etype
(Def_Id
))
8402 ("cannot import object of an access type??", Arg_Internal
);
8405 if Warn_On_Export_Import
8406 and then Is_Imported
(Def_Id
)
8408 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8410 -- Check for explicit initialization present. Note that an
8411 -- initialization generated by the code generator, e.g. for an
8412 -- access type, does not count here.
8414 elsif Present
(Expression
(Parent
(Def_Id
)))
8417 (Original_Node
(Expression
(Parent
(Def_Id
))))
8419 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8421 ("imported entities cannot be initialized (RM B.1(24))",
8422 "\no initialization allowed for & declared#", Arg1
);
8424 Set_Imported
(Def_Id
);
8425 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8428 end Process_Extended_Import_Export_Object_Pragma
;
8430 ------------------------------------------------------
8431 -- Process_Extended_Import_Export_Subprogram_Pragma --
8432 ------------------------------------------------------
8434 procedure Process_Extended_Import_Export_Subprogram_Pragma
8435 (Arg_Internal
: Node_Id
;
8436 Arg_External
: Node_Id
;
8437 Arg_Parameter_Types
: Node_Id
;
8438 Arg_Result_Type
: Node_Id
:= Empty
;
8439 Arg_Mechanism
: Node_Id
;
8440 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8446 Ambiguous
: Boolean;
8449 function Same_Base_Type
8451 Formal
: Entity_Id
) return Boolean;
8452 -- Determines if Ptype references the type of Formal. Note that only
8453 -- the base types need to match according to the spec. Ptype here is
8454 -- the argument from the pragma, which is either a type name, or an
8455 -- access attribute.
8457 --------------------
8458 -- Same_Base_Type --
8459 --------------------
8461 function Same_Base_Type
8463 Formal
: Entity_Id
) return Boolean
8465 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8469 -- Case where pragma argument is typ'Access
8471 if Nkind
(Ptype
) = N_Attribute_Reference
8472 and then Attribute_Name
(Ptype
) = Name_Access
8474 Pref
:= Prefix
(Ptype
);
8477 if not Is_Entity_Name
(Pref
)
8478 or else Entity
(Pref
) = Any_Type
8483 -- We have a match if the corresponding argument is of an
8484 -- anonymous access type, and its designated type matches the
8485 -- type of the prefix of the access attribute
8487 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8488 and then Base_Type
(Entity
(Pref
)) =
8489 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8491 -- Case where pragma argument is a type name
8496 if not Is_Entity_Name
(Ptype
)
8497 or else Entity
(Ptype
) = Any_Type
8502 -- We have a match if the corresponding argument is of the type
8503 -- given in the pragma (comparing base types)
8505 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8509 -- Start of processing for
8510 -- Process_Extended_Import_Export_Subprogram_Pragma
8513 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8517 -- Loop through homonyms (overloadings) of the entity
8519 Hom_Id
:= Entity
(Arg_Internal
);
8520 while Present
(Hom_Id
) loop
8521 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8523 -- We need a subprogram in the current scope
8525 if not Is_Subprogram
(Def_Id
)
8526 or else Scope
(Def_Id
) /= Current_Scope
8533 -- Pragma cannot apply to subprogram body
8535 if Is_Subprogram
(Def_Id
)
8536 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8540 ("pragma% requires separate spec and must come before "
8544 -- Test result type if given, note that the result type
8545 -- parameter can only be present for the function cases.
8547 if Present
(Arg_Result_Type
)
8548 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8552 elsif Etype
(Def_Id
) /= Standard_Void_Type
8553 and then Nam_In
(Pname
, Name_Export_Procedure
,
8554 Name_Import_Procedure
)
8558 -- Test parameter types if given. Note that this parameter has
8559 -- not been analyzed (and must not be, since it is semantic
8560 -- nonsense), so we get it as the parser left it.
8562 elsif Present
(Arg_Parameter_Types
) then
8563 Check_Matching_Types
: declare
8568 Formal
:= First_Formal
(Def_Id
);
8570 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8571 if Present
(Formal
) then
8575 -- A list of one type, e.g. (List) is parsed as a
8576 -- parenthesized expression.
8578 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8579 and then Paren_Count
(Arg_Parameter_Types
) = 1
8582 or else Present
(Next_Formal
(Formal
))
8587 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8590 -- A list of more than one type is parsed as a aggregate
8592 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8593 and then Paren_Count
(Arg_Parameter_Types
) = 0
8595 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8596 while Present
(Ptype
) or else Present
(Formal
) loop
8599 or else not Same_Base_Type
(Ptype
, Formal
)
8604 Next_Formal
(Formal
);
8609 -- Anything else is of the wrong form
8613 ("wrong form for Parameter_Types parameter",
8614 Arg_Parameter_Types
);
8616 end Check_Matching_Types
;
8619 -- Match is now False if the entry we found did not match
8620 -- either a supplied Parameter_Types or Result_Types argument
8626 -- Ambiguous case, the flag Ambiguous shows if we already
8627 -- detected this and output the initial messages.
8630 if not Ambiguous
then
8632 Error_Msg_Name_1
:= Pname
;
8634 ("pragma% does not uniquely identify subprogram!",
8636 Error_Msg_Sloc
:= Sloc
(Ent
);
8637 Error_Msg_N
("matching subprogram #!", N
);
8641 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8642 Error_Msg_N
("matching subprogram #!", N
);
8647 Hom_Id
:= Homonym
(Hom_Id
);
8650 -- See if we found an entry
8653 if not Ambiguous
then
8654 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8656 ("pragma% cannot be given for generic subprogram");
8659 ("pragma% does not identify local subprogram");
8666 -- Import pragmas must be for imported entities
8668 if Prag_Id
= Pragma_Import_Function
8670 Prag_Id
= Pragma_Import_Procedure
8672 Prag_Id
= Pragma_Import_Valued_Procedure
8674 if not Is_Imported
(Ent
) then
8676 ("pragma Import or Interface must precede pragma%");
8679 -- Here we have the Export case which can set the entity as exported
8681 -- But does not do so if the specified external name is null, since
8682 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8683 -- compatible) to request no external name.
8685 elsif Nkind
(Arg_External
) = N_String_Literal
8686 and then String_Length
(Strval
(Arg_External
)) = 0
8690 -- In all other cases, set entity as exported
8693 Set_Exported
(Ent
, Arg_Internal
);
8696 -- Special processing for Valued_Procedure cases
8698 if Prag_Id
= Pragma_Import_Valued_Procedure
8700 Prag_Id
= Pragma_Export_Valued_Procedure
8702 Formal
:= First_Formal
(Ent
);
8705 Error_Pragma
("at least one parameter required for pragma%");
8707 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8708 Error_Pragma
("first parameter must have mode out for pragma%");
8711 Set_Is_Valued_Procedure
(Ent
);
8715 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8717 -- Process Result_Mechanism argument if present. We have already
8718 -- checked that this is only allowed for the function case.
8720 if Present
(Arg_Result_Mechanism
) then
8721 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8724 -- Process Mechanism parameter if present. Note that this parameter
8725 -- is not analyzed, and must not be analyzed since it is semantic
8726 -- nonsense, so we get it in exactly as the parser left it.
8728 if Present
(Arg_Mechanism
) then
8736 -- A single mechanism association without a formal parameter
8737 -- name is parsed as a parenthesized expression. All other
8738 -- cases are parsed as aggregates, so we rewrite the single
8739 -- parameter case as an aggregate for consistency.
8741 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8742 and then Paren_Count
(Arg_Mechanism
) = 1
8744 Rewrite
(Arg_Mechanism
,
8745 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8746 Expressions
=> New_List
(
8747 Relocate_Node
(Arg_Mechanism
))));
8750 -- Case of only mechanism name given, applies to all formals
8752 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8753 Formal
:= First_Formal
(Ent
);
8754 while Present
(Formal
) loop
8755 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8756 Next_Formal
(Formal
);
8759 -- Case of list of mechanism associations given
8762 if Null_Record_Present
(Arg_Mechanism
) then
8764 ("inappropriate form for Mechanism parameter",
8768 -- Deal with positional ones first
8770 Formal
:= First_Formal
(Ent
);
8772 if Present
(Expressions
(Arg_Mechanism
)) then
8773 Mname
:= First
(Expressions
(Arg_Mechanism
));
8774 while Present
(Mname
) loop
8777 ("too many mechanism associations", Mname
);
8780 Set_Mechanism_Value
(Formal
, Mname
);
8781 Next_Formal
(Formal
);
8786 -- Deal with named entries
8788 if Present
(Component_Associations
(Arg_Mechanism
)) then
8789 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8790 while Present
(Massoc
) loop
8791 Choice
:= First
(Choices
(Massoc
));
8793 if Nkind
(Choice
) /= N_Identifier
8794 or else Present
(Next
(Choice
))
8797 ("incorrect form for mechanism association",
8801 Formal
:= First_Formal
(Ent
);
8805 ("parameter name & not present", Choice
);
8808 if Chars
(Choice
) = Chars
(Formal
) then
8810 (Formal
, Expression
(Massoc
));
8812 -- Set entity on identifier (needed by ASIS)
8814 Set_Entity
(Choice
, Formal
);
8819 Next_Formal
(Formal
);
8828 end Process_Extended_Import_Export_Subprogram_Pragma
;
8830 --------------------------
8831 -- Process_Generic_List --
8832 --------------------------
8834 procedure Process_Generic_List
is
8839 Check_No_Identifiers
;
8840 Check_At_Least_N_Arguments
(1);
8842 -- Check all arguments are names of generic units or instances
8845 while Present
(Arg
) loop
8846 Exp
:= Get_Pragma_Arg
(Arg
);
8849 if not Is_Entity_Name
(Exp
)
8851 (not Is_Generic_Instance
(Entity
(Exp
))
8853 not Is_Generic_Unit
(Entity
(Exp
)))
8856 ("pragma% argument must be name of generic unit/instance",
8862 end Process_Generic_List
;
8864 ------------------------------------
8865 -- Process_Import_Predefined_Type --
8866 ------------------------------------
8868 procedure Process_Import_Predefined_Type
is
8869 Loc
: constant Source_Ptr
:= Sloc
(N
);
8871 Ftyp
: Node_Id
:= Empty
;
8877 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8879 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8880 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8884 Ftyp
:= Node
(Elmt
);
8886 if Present
(Ftyp
) then
8888 -- Don't build a derived type declaration, because predefined C
8889 -- types have no declaration anywhere, so cannot really be named.
8890 -- Instead build a full type declaration, starting with an
8891 -- appropriate type definition is built
8893 if Is_Floating_Point_Type
(Ftyp
) then
8894 Def
:= Make_Floating_Point_Definition
(Loc
,
8895 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8896 Make_Real_Range_Specification
(Loc
,
8897 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8898 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8900 -- Should never have a predefined type we cannot handle
8903 raise Program_Error
;
8906 -- Build and insert a Full_Type_Declaration, which will be
8907 -- analyzed as soon as this list entry has been analyzed.
8909 Decl
:= Make_Full_Type_Declaration
(Loc
,
8910 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8911 Type_Definition
=> Def
);
8913 Insert_After
(N
, Decl
);
8914 Mark_Rewrite_Insertion
(Decl
);
8917 Error_Pragma_Arg
("no matching type found for pragma%",
8920 end Process_Import_Predefined_Type
;
8922 ---------------------------------
8923 -- Process_Import_Or_Interface --
8924 ---------------------------------
8926 procedure Process_Import_Or_Interface
is
8932 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8933 -- pragma Import (Entity, "external name");
8935 if Relaxed_RM_Semantics
8936 and then Arg_Count
= 2
8937 and then Prag_Id
= Pragma_Import
8938 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8941 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8944 if not Is_Entity_Name
(Def_Id
) then
8945 Error_Pragma_Arg
("entity name required", Arg1
);
8948 Def_Id
:= Entity
(Def_Id
);
8949 Kill_Size_Check_Code
(Def_Id
);
8950 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8953 Process_Convention
(C
, Def_Id
);
8955 -- A pragma that applies to a Ghost entity becomes Ghost for the
8956 -- purposes of legality checks and removal of ignored Ghost code.
8958 Mark_Ghost_Pragma
(N
, Def_Id
);
8959 Kill_Size_Check_Code
(Def_Id
);
8960 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8963 -- Various error checks
8965 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8967 -- We do not permit Import to apply to a renaming declaration
8969 if Present
(Renamed_Object
(Def_Id
)) then
8971 ("pragma% not allowed for object renaming", Arg2
);
8973 -- User initialization is not allowed for imported object, but
8974 -- the object declaration may contain a default initialization,
8975 -- that will be discarded. Note that an explicit initialization
8976 -- only counts if it comes from source, otherwise it is simply
8977 -- the code generator making an implicit initialization explicit.
8979 elsif Present
(Expression
(Parent
(Def_Id
)))
8980 and then Comes_From_Source
8981 (Original_Node
(Expression
(Parent
(Def_Id
))))
8983 -- Set imported flag to prevent cascaded errors
8985 Set_Is_Imported
(Def_Id
);
8987 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8989 ("no initialization allowed for declaration of& #",
8990 "\imported entities cannot be initialized (RM B.1(24))",
8994 -- If the pragma comes from an aspect specification the
8995 -- Is_Imported flag has already been set.
8997 if not From_Aspect_Specification
(N
) then
8998 Set_Imported
(Def_Id
);
9001 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9003 -- Note that we do not set Is_Public here. That's because we
9004 -- only want to set it if there is no address clause, and we
9005 -- don't know that yet, so we delay that processing till
9008 -- pragma Import completes deferred constants
9010 if Ekind
(Def_Id
) = E_Constant
then
9011 Set_Has_Completion
(Def_Id
);
9014 -- It is not possible to import a constant of an unconstrained
9015 -- array type (e.g. string) because there is no simple way to
9016 -- write a meaningful subtype for it.
9018 if Is_Array_Type
(Etype
(Def_Id
))
9019 and then not Is_Constrained
(Etype
(Def_Id
))
9022 ("imported constant& must have a constrained subtype",
9027 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9029 -- If the name is overloaded, pragma applies to all of the denoted
9030 -- entities in the same declarative part, unless the pragma comes
9031 -- from an aspect specification or was generated by the compiler
9032 -- (such as for pragma Provide_Shift_Operators).
9035 while Present
(Hom_Id
) loop
9037 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9039 -- Ignore inherited subprograms because the pragma will apply
9040 -- to the parent operation, which is the one called.
9042 if Is_Overloadable
(Def_Id
)
9043 and then Present
(Alias
(Def_Id
))
9047 -- If it is not a subprogram, it must be in an outer scope and
9048 -- pragma does not apply.
9050 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9053 -- The pragma does not apply to primitives of interfaces
9055 elsif Is_Dispatching_Operation
(Def_Id
)
9056 and then Present
(Find_Dispatching_Type
(Def_Id
))
9057 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9061 -- Verify that the homonym is in the same declarative part (not
9062 -- just the same scope). If the pragma comes from an aspect
9063 -- specification we know that it is part of the declaration.
9065 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
9066 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9067 and then not From_Aspect_Specification
(N
)
9072 -- If the pragma comes from an aspect specification the
9073 -- Is_Imported flag has already been set.
9075 if not From_Aspect_Specification
(N
) then
9076 Set_Imported
(Def_Id
);
9079 -- Reject an Import applied to an abstract subprogram
9081 if Is_Subprogram
(Def_Id
)
9082 and then Is_Abstract_Subprogram
(Def_Id
)
9084 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9086 ("cannot import abstract subprogram& declared#",
9090 -- Special processing for Convention_Intrinsic
9092 if C
= Convention_Intrinsic
then
9094 -- Link_Name argument not allowed for intrinsic
9098 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9100 -- If no external name is present, then check that this
9101 -- is a valid intrinsic subprogram. If an external name
9102 -- is present, then this is handled by the back end.
9105 Check_Intrinsic_Subprogram
9106 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9110 -- Verify that the subprogram does not have a completion
9111 -- through a renaming declaration. For other completions the
9112 -- pragma appears as a too late representation.
9115 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9119 and then Nkind
(Decl
) = N_Subprogram_Declaration
9120 and then Present
(Corresponding_Body
(Decl
))
9121 and then Nkind
(Unit_Declaration_Node
9122 (Corresponding_Body
(Decl
))) =
9123 N_Subprogram_Renaming_Declaration
9125 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9127 ("cannot import&, renaming already provided for "
9128 & "declaration #", N
, Def_Id
);
9132 -- If the pragma comes from an aspect specification, there
9133 -- must be an Import aspect specified as well. In the rare
9134 -- case where Import is set to False, the suprogram needs to
9135 -- have a local completion.
9138 Imp_Aspect
: constant Node_Id
:=
9139 Find_Aspect
(Def_Id
, Aspect_Import
);
9143 if Present
(Imp_Aspect
)
9144 and then Present
(Expression
(Imp_Aspect
))
9146 Expr
:= Expression
(Imp_Aspect
);
9147 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9149 if Is_Entity_Name
(Expr
)
9150 and then Entity
(Expr
) = Standard_True
9152 Set_Has_Completion
(Def_Id
);
9155 -- If there is no expression, the default is True, as for
9156 -- all boolean aspects. Same for the older pragma.
9159 Set_Has_Completion
(Def_Id
);
9163 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9166 if Is_Compilation_Unit
(Hom_Id
) then
9168 -- Its possible homonyms are not affected by the pragma.
9169 -- Such homonyms might be present in the context of other
9170 -- units being compiled.
9174 elsif From_Aspect_Specification
(N
) then
9177 -- If the pragma was created by the compiler, then we don't
9178 -- want it to apply to other homonyms. This kind of case can
9179 -- occur when using pragma Provide_Shift_Operators, which
9180 -- generates implicit shift and rotate operators with Import
9181 -- pragmas that might apply to earlier explicit or implicit
9182 -- declarations marked with Import (for example, coming from
9183 -- an earlier pragma Provide_Shift_Operators for another type),
9184 -- and we don't generally want other homonyms being treated
9185 -- as imported or the pragma flagged as an illegal duplicate.
9187 elsif not Comes_From_Source
(N
) then
9191 Hom_Id
:= Homonym
(Hom_Id
);
9195 -- Import a CPP class
9197 elsif C
= Convention_CPP
9198 and then (Is_Record_Type
(Def_Id
)
9199 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9201 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9202 if Present
(Full_View
(Def_Id
)) then
9203 Def_Id
:= Full_View
(Def_Id
);
9207 ("cannot import 'C'P'P type before full declaration seen",
9208 Get_Pragma_Arg
(Arg2
));
9210 -- Although we have reported the error we decorate it as
9211 -- CPP_Class to avoid reporting spurious errors
9213 Set_Is_CPP_Class
(Def_Id
);
9218 -- Types treated as CPP classes must be declared limited (note:
9219 -- this used to be a warning but there is no real benefit to it
9220 -- since we did effectively intend to treat the type as limited
9223 if not Is_Limited_Type
(Def_Id
) then
9225 ("imported 'C'P'P type must be limited",
9226 Get_Pragma_Arg
(Arg2
));
9229 if Etype
(Def_Id
) /= Def_Id
9230 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9232 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9235 Set_Is_CPP_Class
(Def_Id
);
9237 -- Imported CPP types must not have discriminants (because C++
9238 -- classes do not have discriminants).
9240 if Has_Discriminants
(Def_Id
) then
9242 ("imported 'C'P'P type cannot have discriminants",
9243 First
(Discriminant_Specifications
9244 (Declaration_Node
(Def_Id
))));
9247 -- Check that components of imported CPP types do not have default
9248 -- expressions. For private types this check is performed when the
9249 -- full view is analyzed (see Process_Full_View).
9251 if not Is_Private_Type
(Def_Id
) then
9252 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9255 -- Import a CPP exception
9257 elsif C
= Convention_CPP
9258 and then Ekind
(Def_Id
) = E_Exception
9262 ("'External_'Name arguments is required for 'Cpp exception",
9265 -- As only a string is allowed, Check_Arg_Is_External_Name
9268 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9271 if Present
(Arg4
) then
9273 ("Link_Name argument not allowed for imported Cpp exception",
9277 -- Do not call Set_Interface_Name as the name of the exception
9278 -- shouldn't be modified (and in particular it shouldn't be
9279 -- the External_Name). For exceptions, the External_Name is the
9280 -- name of the RTTI structure.
9282 -- ??? Emit an error if pragma Import/Export_Exception is present
9284 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9286 Check_Arg_Count
(3);
9287 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9289 Process_Import_Predefined_Type
;
9293 ("second argument of pragma% must be object, subprogram "
9294 & "or incomplete type",
9298 -- If this pragma applies to a compilation unit, then the unit, which
9299 -- is a subprogram, does not require (or allow) a body. We also do
9300 -- not need to elaborate imported procedures.
9302 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9304 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9306 Set_Body_Required
(Cunit
, False);
9309 end Process_Import_Or_Interface
;
9311 --------------------
9312 -- Process_Inline --
9313 --------------------
9315 procedure Process_Inline
(Status
: Inline_Status
) is
9322 Ghost_Error_Posted
: Boolean := False;
9323 -- Flag set when an error concerning the illegal mix of Ghost and
9324 -- non-Ghost subprograms is emitted.
9326 Ghost_Id
: Entity_Id
:= Empty
;
9327 -- The entity of the first Ghost subprogram encountered while
9328 -- processing the arguments of the pragma.
9330 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9331 -- Verify the placement of pragma Inline_Always with respect to the
9332 -- initial declaration of subprogram Spec_Id.
9334 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9335 -- Returns True if it can be determined at this stage that inlining
9336 -- is not possible, for example if the body is available and contains
9337 -- exception handlers, we prevent inlining, since otherwise we can
9338 -- get undefined symbols at link time. This function also emits a
9339 -- warning if the pragma appears too late.
9341 -- ??? is business with link symbols still valid, or does it relate
9342 -- to front end ZCX which is being phased out ???
9344 procedure Make_Inline
(Subp
: Entity_Id
);
9345 -- Subp is the defining unit name of the subprogram declaration. If
9346 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9347 -- the corresponding body, if there is one present.
9349 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9350 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9351 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9353 -----------------------------------
9354 -- Check_Inline_Always_Placement --
9355 -----------------------------------
9357 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9358 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9360 function Compilation_Unit_OK
return Boolean;
9361 pragma Inline
(Compilation_Unit_OK
);
9362 -- Determine whether pragma Inline_Always applies to a compatible
9363 -- compilation unit denoted by Spec_Id.
9365 function Declarative_List_OK
return Boolean;
9366 pragma Inline
(Declarative_List_OK
);
9367 -- Determine whether the initial declaration of subprogram Spec_Id
9368 -- and the pragma appear in compatible declarative lists.
9370 function Subprogram_Body_OK
return Boolean;
9371 pragma Inline
(Subprogram_Body_OK
);
9372 -- Determine whether pragma Inline_Always applies to a compatible
9373 -- subprogram body denoted by Spec_Id.
9375 -------------------------
9376 -- Compilation_Unit_OK --
9377 -------------------------
9379 function Compilation_Unit_OK
return Boolean is
9380 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9383 -- The pragma appears after the initial declaration of a
9384 -- compilation unit.
9386 -- procedure Comp_Unit;
9387 -- pragma Inline_Always (Comp_Unit);
9389 -- Note that for compatibility reasons, the following case is
9392 -- procedure Stand_Alone_Body_Comp_Unit is
9394 -- end Stand_Alone_Body_Comp_Unit;
9395 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9398 Nkind
(Comp_Unit
) = N_Compilation_Unit
9399 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9400 and then Is_List_Member
(N
)
9401 and then List_Containing
(N
) =
9402 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9403 end Compilation_Unit_OK
;
9405 -------------------------
9406 -- Declarative_List_OK --
9407 -------------------------
9409 function Declarative_List_OK
return Boolean is
9410 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9412 Init_Decl
: Node_Id
;
9413 Init_List
: List_Id
;
9414 Prag_List
: List_Id
;
9417 -- Determine the proper initial declaration. In general this is
9418 -- the declaration node of the subprogram except when the input
9419 -- denotes a generic instantiation.
9421 -- procedure Inst is new Gen;
9422 -- pragma Inline_Always (Inst);
9424 -- In this case the original subprogram is moved inside an
9425 -- anonymous package while pragma Inline_Always remains at the
9426 -- level of the anonymous package. Use the declaration of the
9427 -- package because it reflects the placement of the original
9430 -- package Anon_Pack is
9431 -- procedure Inst is ... end Inst; -- original
9434 -- procedure Inst renames Anon_Pack.Inst;
9435 -- pragma Inline_Always (Inst);
9437 if Is_Generic_Instance
(Spec_Id
) then
9438 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9439 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9441 Init_Decl
:= Spec_Decl
;
9444 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9445 Init_List
:= List_Containing
(Init_Decl
);
9446 Prag_List
:= List_Containing
(N
);
9448 -- The pragma and then initial declaration appear within the
9449 -- same declarative list.
9451 if Init_List
= Prag_List
then
9454 -- A special case of the above is when both the pragma and
9455 -- the initial declaration appear in different lists of a
9456 -- package spec, protected definition, or a task definition.
9461 -- pragma Inline_Always (Proc);
9464 elsif Nkind_In
(Context
, N_Package_Specification
,
9465 N_Protected_Definition
,
9467 and then Init_List
= Visible_Declarations
(Context
)
9468 and then Prag_List
= Private_Declarations
(Context
)
9475 end Declarative_List_OK
;
9477 ------------------------
9478 -- Subprogram_Body_OK --
9479 ------------------------
9481 function Subprogram_Body_OK
return Boolean is
9482 Body_Decl
: Node_Id
;
9485 -- The pragma appears within the declarative list of a stand-
9486 -- alone subprogram body.
9488 -- procedure Stand_Alone_Body is
9489 -- pragma Inline_Always (Stand_Alone_Body);
9492 -- end Stand_Alone_Body;
9494 -- The compiler creates a dummy spec in this case, however the
9495 -- pragma remains within the declarative list of the body.
9497 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9498 and then not Comes_From_Source
(Spec_Decl
)
9499 and then Present
(Corresponding_Body
(Spec_Decl
))
9502 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9504 if Present
(Declarations
(Body_Decl
))
9505 and then Is_List_Member
(N
)
9506 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9513 end Subprogram_Body_OK
;
9515 -- Start of processing for Check_Inline_Always_Placement
9518 -- This check is relevant only for pragma Inline_Always
9520 if Pname
/= Name_Inline_Always
then
9523 -- Nothing to do when the pragma is internally generated on the
9524 -- assumption that it is properly placed.
9526 elsif not Comes_From_Source
(N
) then
9529 -- Nothing to do for internally generated subprograms that act
9530 -- as accidental homonyms of a source subprogram being inlined.
9532 elsif not Comes_From_Source
(Spec_Id
) then
9535 -- Nothing to do for generic formal subprograms that act as
9536 -- homonyms of another source subprogram being inlined.
9538 elsif Is_Formal_Subprogram
(Spec_Id
) then
9541 elsif Compilation_Unit_OK
9542 or else Declarative_List_OK
9543 or else Subprogram_Body_OK
9548 -- At this point it is known that the pragma applies to or appears
9549 -- within a completing body, a completing stub, or a subunit.
9551 Error_Msg_Name_1
:= Pname
;
9552 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9553 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9556 ("pragma % must appear on initial declaration of subprogram "
9557 & "% defined #", N
);
9558 end Check_Inline_Always_Placement
;
9560 ---------------------------
9561 -- Inlining_Not_Possible --
9562 ---------------------------
9564 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9565 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9569 if Nkind
(Decl
) = N_Subprogram_Body
then
9570 Stats
:= Handled_Statement_Sequence
(Decl
);
9571 return Present
(Exception_Handlers
(Stats
))
9572 or else Present
(At_End_Proc
(Stats
));
9574 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9575 and then Present
(Corresponding_Body
(Decl
))
9577 if Analyzed
(Corresponding_Body
(Decl
)) then
9578 Error_Msg_N
("pragma appears too late, ignored??", N
);
9581 -- If the subprogram is a renaming as body, the body is just a
9582 -- call to the renamed subprogram, and inlining is trivially
9586 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9587 N_Subprogram_Renaming_Declaration
9593 Handled_Statement_Sequence
9594 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9597 Present
(Exception_Handlers
(Stats
))
9598 or else Present
(At_End_Proc
(Stats
));
9602 -- If body is not available, assume the best, the check is
9603 -- performed again when compiling enclosing package bodies.
9607 end Inlining_Not_Possible
;
9613 procedure Make_Inline
(Subp
: Entity_Id
) is
9614 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9615 Inner_Subp
: Entity_Id
:= Subp
;
9618 -- Ignore if bad type, avoid cascaded error
9620 if Etype
(Subp
) = Any_Type
then
9624 -- If inlining is not possible, for now do not treat as an error
9626 elsif Status
/= Suppressed
9627 and then Front_End_Inlining
9628 and then Inlining_Not_Possible
(Subp
)
9633 -- Here we have a candidate for inlining, but we must exclude
9634 -- derived operations. Otherwise we would end up trying to inline
9635 -- a phantom declaration, and the result would be to drag in a
9636 -- body which has no direct inlining associated with it. That
9637 -- would not only be inefficient but would also result in the
9638 -- backend doing cross-unit inlining in cases where it was
9639 -- definitely inappropriate to do so.
9641 -- However, a simple Comes_From_Source test is insufficient, since
9642 -- we do want to allow inlining of generic instances which also do
9643 -- not come from source. We also need to recognize specs generated
9644 -- by the front-end for bodies that carry the pragma. Finally,
9645 -- predefined operators do not come from source but are not
9646 -- inlineable either.
9648 elsif Is_Generic_Instance
(Subp
)
9649 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9653 elsif not Comes_From_Source
(Subp
)
9654 and then Scope
(Subp
) /= Standard_Standard
9660 -- The referenced entity must either be the enclosing entity, or
9661 -- an entity declared within the current open scope.
9663 if Present
(Scope
(Subp
))
9664 and then Scope
(Subp
) /= Current_Scope
9665 and then Subp
/= Current_Scope
9668 ("argument of% must be entity in current scope", Assoc
);
9672 -- Processing for procedure, operator or function. If subprogram
9673 -- is aliased (as for an instance) indicate that the renamed
9674 -- entity (if declared in the same unit) is inlined.
9675 -- If this is the anonymous subprogram created for a subprogram
9676 -- instance, the inlining applies to it directly. Otherwise we
9677 -- retrieve it as the alias of the visible subprogram instance.
9679 if Is_Subprogram
(Subp
) then
9681 -- Ensure that pragma Inline_Always is associated with the
9682 -- initial declaration of the subprogram.
9684 Check_Inline_Always_Placement
(Subp
);
9686 if Is_Wrapper_Package
(Scope
(Subp
)) then
9689 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9692 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9693 Set_Inline_Flags
(Inner_Subp
);
9695 Decl
:= Parent
(Parent
(Inner_Subp
));
9697 if Nkind
(Decl
) = N_Subprogram_Declaration
9698 and then Present
(Corresponding_Body
(Decl
))
9700 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9702 elsif Is_Generic_Instance
(Subp
)
9703 and then Comes_From_Source
(Subp
)
9705 -- Indicate that the body needs to be created for
9706 -- inlining subsequent calls. The instantiation node
9707 -- follows the declaration of the wrapper package
9708 -- created for it. The subprogram that requires the
9709 -- body is the anonymous one in the wrapper package.
9711 if Scope
(Subp
) /= Standard_Standard
9713 Need_Subprogram_Instance_Body
9714 (Next
(Unit_Declaration_Node
9715 (Scope
(Alias
(Subp
)))), Subp
)
9720 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9721 -- appear in a formal part to apply to a formal subprogram.
9722 -- Do not apply check within an instance or a formal package
9723 -- the test will have been applied to the original generic.
9725 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9726 and then List_Containing
(Decl
) = List_Containing
(N
)
9727 and then not In_Instance
9730 ("Inline cannot apply to a formal subprogram", N
);
9732 -- If Subp is a renaming, it is the renamed entity that
9733 -- will appear in any call, and be inlined. However, for
9734 -- ASIS uses it is convenient to indicate that the renaming
9735 -- itself is an inlined subprogram, so that some gnatcheck
9736 -- rules can be applied in the absence of expansion.
9738 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9739 Set_Inline_Flags
(Subp
);
9745 -- For a generic subprogram set flag as well, for use at the point
9746 -- of instantiation, to determine whether the body should be
9749 elsif Is_Generic_Subprogram
(Subp
) then
9750 Set_Inline_Flags
(Subp
);
9753 -- Literals are by definition inlined
9755 elsif Kind
= E_Enumeration_Literal
then
9758 -- Anything else is an error
9762 ("expect subprogram name for pragma%", Assoc
);
9766 ----------------------
9767 -- Set_Inline_Flags --
9768 ----------------------
9770 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9772 -- First set the Has_Pragma_XXX flags and issue the appropriate
9773 -- errors and warnings for suspicious combinations.
9775 if Prag_Id
= Pragma_No_Inline
then
9776 if Has_Pragma_Inline_Always
(Subp
) then
9778 ("Inline_Always and No_Inline are mutually exclusive", N
);
9779 elsif Has_Pragma_Inline
(Subp
) then
9781 ("Inline and No_Inline both specified for& ??",
9782 N
, Entity
(Subp_Id
));
9785 Set_Has_Pragma_No_Inline
(Subp
);
9787 if Prag_Id
= Pragma_Inline_Always
then
9788 if Has_Pragma_No_Inline
(Subp
) then
9790 ("Inline_Always and No_Inline are mutually exclusive",
9794 Set_Has_Pragma_Inline_Always
(Subp
);
9796 if Has_Pragma_No_Inline
(Subp
) then
9798 ("Inline and No_Inline both specified for& ??",
9799 N
, Entity
(Subp_Id
));
9803 Set_Has_Pragma_Inline
(Subp
);
9806 -- Then adjust the Is_Inlined flag. It can never be set if the
9807 -- subprogram is subject to pragma No_Inline.
9811 Set_Is_Inlined
(Subp
, False);
9817 if not Has_Pragma_No_Inline
(Subp
) then
9818 Set_Is_Inlined
(Subp
, True);
9822 -- A pragma that applies to a Ghost entity becomes Ghost for the
9823 -- purposes of legality checks and removal of ignored Ghost code.
9825 Mark_Ghost_Pragma
(N
, Subp
);
9827 -- Capture the entity of the first Ghost subprogram being
9828 -- processed for error detection purposes.
9830 if Is_Ghost_Entity
(Subp
) then
9831 if No
(Ghost_Id
) then
9835 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9836 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9838 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9839 Ghost_Error_Posted
:= True;
9841 Error_Msg_Name_1
:= Pname
;
9843 ("pragma % cannot mention ghost and non-ghost subprograms",
9846 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9847 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9849 Error_Msg_Sloc
:= Sloc
(Subp
);
9850 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9852 end Set_Inline_Flags
;
9854 -- Start of processing for Process_Inline
9857 Check_No_Identifiers
;
9858 Check_At_Least_N_Arguments
(1);
9860 if Status
= Enabled
then
9861 Inline_Processing_Required
:= True;
9865 while Present
(Assoc
) loop
9866 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9870 if Is_Entity_Name
(Subp_Id
) then
9871 Subp
:= Entity
(Subp_Id
);
9873 if Subp
= Any_Id
then
9875 -- If previous error, avoid cascaded errors
9877 Check_Error_Detected
;
9883 -- For the pragma case, climb homonym chain. This is
9884 -- what implements allowing the pragma in the renaming
9885 -- case, with the result applying to the ancestors, and
9886 -- also allows Inline to apply to all previous homonyms.
9888 if not From_Aspect_Specification
(N
) then
9889 while Present
(Homonym
(Subp
))
9890 and then Scope
(Homonym
(Subp
)) = Current_Scope
9892 Make_Inline
(Homonym
(Subp
));
9893 Subp
:= Homonym
(Subp
);
9900 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9906 -- If the context is a package declaration, the pragma indicates
9907 -- that inlining will require the presence of the corresponding
9908 -- body. (this may be further refined).
9911 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9912 N_Package_Declaration
9914 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9918 ----------------------------
9919 -- Process_Interface_Name --
9920 ----------------------------
9922 procedure Process_Interface_Name
9923 (Subprogram_Def
: Entity_Id
;
9930 String_Val
: String_Id
;
9932 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9933 -- SN is a string literal node for an interface name. This routine
9934 -- performs some minimal checks that the name is reasonable. In
9935 -- particular that no spaces or other obviously incorrect characters
9936 -- appear. This is only a warning, since any characters are allowed.
9938 ----------------------------------
9939 -- Check_Form_Of_Interface_Name --
9940 ----------------------------------
9942 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9943 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9944 SL
: constant Nat
:= String_Length
(S
);
9949 Error_Msg_N
("interface name cannot be null string", SN
);
9952 for J
in 1 .. SL
loop
9953 C
:= Get_String_Char
(S
, J
);
9955 -- Look for dubious character and issue unconditional warning.
9956 -- Definitely dubious if not in character range.
9958 if not In_Character_Range
(C
)
9960 -- Commas, spaces and (back)slashes are dubious
9962 or else Get_Character
(C
) = ','
9963 or else Get_Character
(C
) = '\'
9964 or else Get_Character
(C
) = ' '
9965 or else Get_Character
(C
) = '/'
9968 ("??interface name contains illegal character",
9969 Sloc
(SN
) + Source_Ptr
(J
));
9972 end Check_Form_Of_Interface_Name
;
9974 -- Start of processing for Process_Interface_Name
9977 -- If we are looking at a pragma that comes from an aspect then it
9978 -- needs to have its corresponding aspect argument expressions
9979 -- analyzed in addition to the generated pragma so that aspects
9980 -- within generic units get properly resolved.
9982 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9984 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9992 -- Obtain all interfacing aspects used to construct the pragma
9994 Get_Interfacing_Aspects
9995 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9997 -- Analyze the expression of aspect External_Name
9999 if Present
(EN
) then
10000 Analyze
(Expression
(EN
));
10003 -- Analyze the expressio of aspect Link_Name
10005 if Present
(LN
) then
10006 Analyze
(Expression
(LN
));
10011 if No
(Link_Arg
) then
10012 if No
(Ext_Arg
) then
10015 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10017 Link_Nam
:= Expression
(Ext_Arg
);
10020 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10021 Ext_Nam
:= Expression
(Ext_Arg
);
10026 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10027 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10028 Ext_Nam
:= Expression
(Ext_Arg
);
10029 Link_Nam
:= Expression
(Link_Arg
);
10032 -- Check expressions for external name and link name are static
10034 if Present
(Ext_Nam
) then
10035 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10036 Check_Form_Of_Interface_Name
(Ext_Nam
);
10038 -- Verify that external name is not the name of a local entity,
10039 -- which would hide the imported one and could lead to run-time
10040 -- surprises. The problem can only arise for entities declared in
10041 -- a package body (otherwise the external name is fully qualified
10042 -- and will not conflict).
10050 if Prag_Id
= Pragma_Import
then
10051 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10052 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10054 if Nam
/= Chars
(Subprogram_Def
)
10055 and then Present
(E
)
10056 and then not Is_Overloadable
(E
)
10057 and then Is_Immediately_Visible
(E
)
10058 and then not Is_Imported
(E
)
10059 and then Ekind
(Scope
(E
)) = E_Package
10062 while Present
(Par
) loop
10063 if Nkind
(Par
) = N_Package_Body
then
10064 Error_Msg_Sloc
:= Sloc
(E
);
10066 ("imported entity is hidden by & declared#",
10071 Par
:= Parent
(Par
);
10078 if Present
(Link_Nam
) then
10079 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10080 Check_Form_Of_Interface_Name
(Link_Nam
);
10083 -- If there is no link name, just set the external name
10085 if No
(Link_Nam
) then
10086 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10088 -- For the Link_Name case, the given literal is preceded by an
10089 -- asterisk, which indicates to GCC that the given name should be
10090 -- taken literally, and in particular that no prepending of
10091 -- underlines should occur, even in systems where this is the
10096 Store_String_Char
(Get_Char_Code
('*'));
10097 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10098 Store_String_Chars
(String_Val
);
10100 Make_String_Literal
(Sloc
(Link_Nam
),
10101 Strval
=> End_String
);
10104 -- Set the interface name. If the entity is a generic instance, use
10105 -- its alias, which is the callable entity.
10107 if Is_Generic_Instance
(Subprogram_Def
) then
10108 Set_Encoded_Interface_Name
10109 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10111 Set_Encoded_Interface_Name
10112 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10115 Check_Duplicated_Export_Name
(Link_Nam
);
10116 end Process_Interface_Name
;
10118 -----------------------------------------
10119 -- Process_Interrupt_Or_Attach_Handler --
10120 -----------------------------------------
10122 procedure Process_Interrupt_Or_Attach_Handler
is
10123 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10124 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10127 -- A pragma that applies to a Ghost entity becomes Ghost for the
10128 -- purposes of legality checks and removal of ignored Ghost code.
10130 Mark_Ghost_Pragma
(N
, Handler
);
10131 Set_Is_Interrupt_Handler
(Handler
);
10133 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10135 Record_Rep_Item
(Prot_Typ
, N
);
10137 -- Chain the pragma on the contract for completeness
10139 Add_Contract_Item
(N
, Handler
);
10140 end Process_Interrupt_Or_Attach_Handler
;
10142 --------------------------------------------------
10143 -- Process_Restrictions_Or_Restriction_Warnings --
10144 --------------------------------------------------
10146 -- Note: some of the simple identifier cases were handled in par-prag,
10147 -- but it is harmless (and more straightforward) to simply handle all
10148 -- cases here, even if it means we repeat a bit of work in some cases.
10150 procedure Process_Restrictions_Or_Restriction_Warnings
10154 R_Id
: Restriction_Id
;
10160 -- Ignore all Restrictions pragmas in CodePeer mode
10162 if CodePeer_Mode
then
10166 Check_Ada_83_Warning
;
10167 Check_At_Least_N_Arguments
(1);
10168 Check_Valid_Configuration_Pragma
;
10171 while Present
(Arg
) loop
10173 Expr
:= Get_Pragma_Arg
(Arg
);
10175 -- Case of no restriction identifier present
10177 if Id
= No_Name
then
10178 if Nkind
(Expr
) /= N_Identifier
then
10180 ("invalid form for restriction", Arg
);
10185 (Process_Restriction_Synonyms
(Expr
));
10187 if R_Id
not in All_Boolean_Restrictions
then
10188 Error_Msg_Name_1
:= Pname
;
10190 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10192 -- Check for possible misspelling
10194 for J
in Restriction_Id
loop
10196 Rnm
: constant String := Restriction_Id
'Image (J
);
10199 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10200 Name_Len
:= Rnm
'Length;
10201 Set_Casing
(All_Lower_Case
);
10203 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10206 (Source_Index
(Current_Sem_Unit
)));
10207 Error_Msg_String
(1 .. Rnm
'Length) :=
10208 Name_Buffer
(1 .. Name_Len
);
10209 Error_Msg_Strlen
:= Rnm
'Length;
10210 Error_Msg_N
-- CODEFIX
10211 ("\possible misspelling of ""~""",
10212 Get_Pragma_Arg
(Arg
));
10221 if Implementation_Restriction
(R_Id
) then
10222 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10225 -- Special processing for No_Elaboration_Code restriction
10227 if R_Id
= No_Elaboration_Code
then
10229 -- Restriction is only recognized within a configuration
10230 -- pragma file, or within a unit of the main extended
10231 -- program. Note: the test for Main_Unit is needed to
10232 -- properly include the case of configuration pragma files.
10234 if not (Current_Sem_Unit
= Main_Unit
10235 or else In_Extended_Main_Source_Unit
(N
))
10239 -- Don't allow in a subunit unless already specified in
10242 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10243 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10244 and then not Restriction_Active
(No_Elaboration_Code
)
10247 ("invalid specification of ""No_Elaboration_Code""",
10250 ("\restriction cannot be specified in a subunit", N
);
10252 ("\unless also specified in body or spec", N
);
10255 -- If we accept a No_Elaboration_Code restriction, then it
10256 -- needs to be added to the configuration restriction set so
10257 -- that we get proper application to other units in the main
10258 -- extended source as required.
10261 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10265 -- If this is a warning, then set the warning unless we already
10266 -- have a real restriction active (we never want a warning to
10267 -- override a real restriction).
10270 if not Restriction_Active
(R_Id
) then
10271 Set_Restriction
(R_Id
, N
);
10272 Restriction_Warnings
(R_Id
) := True;
10275 -- If real restriction case, then set it and make sure that the
10276 -- restriction warning flag is off, since a real restriction
10277 -- always overrides a warning.
10280 Set_Restriction
(R_Id
, N
);
10281 Restriction_Warnings
(R_Id
) := False;
10284 -- Check for obsolescent restrictions in Ada 2005 mode
10287 and then Ada_Version
>= Ada_2005
10288 and then (R_Id
= No_Asynchronous_Control
10290 R_Id
= No_Unchecked_Deallocation
10292 R_Id
= No_Unchecked_Conversion
)
10294 Check_Restriction
(No_Obsolescent_Features
, N
);
10297 -- A very special case that must be processed here: pragma
10298 -- Restrictions (No_Exceptions) turns off all run-time
10299 -- checking. This is a bit dubious in terms of the formal
10300 -- language definition, but it is what is intended by RM
10301 -- H.4(12). Restriction_Warnings never affects generated code
10302 -- so this is done only in the real restriction case.
10304 -- Atomic_Synchronization is not a real check, so it is not
10305 -- affected by this processing).
10307 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10308 -- run-time checks in CodePeer and GNATprove modes: we want to
10309 -- generate checks for analysis purposes, as set respectively
10310 -- by -gnatC and -gnatd.F
10313 and then not (CodePeer_Mode
or GNATprove_Mode
)
10314 and then R_Id
= No_Exceptions
10316 for J
in Scope_Suppress
.Suppress
'Range loop
10317 if J
/= Atomic_Synchronization
then
10318 Scope_Suppress
.Suppress
(J
) := True;
10323 -- Case of No_Dependence => unit-name. Note that the parser
10324 -- already made the necessary entry in the No_Dependence table.
10326 elsif Id
= Name_No_Dependence
then
10327 if not OK_No_Dependence_Unit_Name
(Expr
) then
10331 -- Case of No_Specification_Of_Aspect => aspect-identifier
10333 elsif Id
= Name_No_Specification_Of_Aspect
then
10338 if Nkind
(Expr
) /= N_Identifier
then
10341 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10344 if A_Id
= No_Aspect
then
10345 Error_Pragma_Arg
("invalid restriction name", Arg
);
10347 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10351 -- Case of No_Use_Of_Attribute => attribute-identifier
10353 elsif Id
= Name_No_Use_Of_Attribute
then
10354 if Nkind
(Expr
) /= N_Identifier
10355 or else not Is_Attribute_Name
(Chars
(Expr
))
10357 Error_Msg_N
("unknown attribute name??", Expr
);
10360 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10363 -- Case of No_Use_Of_Entity => fully-qualified-name
10365 elsif Id
= Name_No_Use_Of_Entity
then
10367 -- Restriction is only recognized within a configuration
10368 -- pragma file, or within a unit of the main extended
10369 -- program. Note: the test for Main_Unit is needed to
10370 -- properly include the case of configuration pragma files.
10372 if Current_Sem_Unit
= Main_Unit
10373 or else In_Extended_Main_Source_Unit
(N
)
10375 if not OK_No_Dependence_Unit_Name
(Expr
) then
10376 Error_Msg_N
("wrong form for entity name", Expr
);
10378 Set_Restriction_No_Use_Of_Entity
10379 (Expr
, Warn
, No_Profile
);
10383 -- Case of No_Use_Of_Pragma => pragma-identifier
10385 elsif Id
= Name_No_Use_Of_Pragma
then
10386 if Nkind
(Expr
) /= N_Identifier
10387 or else not Is_Pragma_Name
(Chars
(Expr
))
10389 Error_Msg_N
("unknown pragma name??", Expr
);
10391 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10394 -- All other cases of restriction identifier present
10397 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10398 Analyze_And_Resolve
(Expr
, Any_Integer
);
10400 if R_Id
not in All_Parameter_Restrictions
then
10402 ("invalid restriction parameter identifier", Arg
);
10404 elsif not Is_OK_Static_Expression
(Expr
) then
10405 Flag_Non_Static_Expr
10406 ("value must be static expression!", Expr
);
10409 elsif not Is_Integer_Type
(Etype
(Expr
))
10410 or else Expr_Value
(Expr
) < 0
10413 ("value must be non-negative integer", Arg
);
10416 -- Restriction pragma is active
10418 Val
:= Expr_Value
(Expr
);
10420 if not UI_Is_In_Int_Range
(Val
) then
10422 ("pragma ignored, value too large??", Arg
);
10425 -- Warning case. If the real restriction is active, then we
10426 -- ignore the request, since warning never overrides a real
10427 -- restriction. Otherwise we set the proper warning. Note that
10428 -- this circuit sets the warning again if it is already set,
10429 -- which is what we want, since the constant may have changed.
10432 if not Restriction_Active
(R_Id
) then
10434 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10435 Restriction_Warnings
(R_Id
) := True;
10438 -- Real restriction case, set restriction and make sure warning
10439 -- flag is off since real restriction always overrides warning.
10442 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10443 Restriction_Warnings
(R_Id
) := False;
10449 end Process_Restrictions_Or_Restriction_Warnings
;
10451 ---------------------------------
10452 -- Process_Suppress_Unsuppress --
10453 ---------------------------------
10455 -- Note: this procedure makes entries in the check suppress data
10456 -- structures managed by Sem. See spec of package Sem for full
10457 -- details on how we handle recording of check suppression.
10459 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10464 In_Package_Spec
: constant Boolean :=
10465 Is_Package_Or_Generic_Package
(Current_Scope
)
10466 and then not In_Package_Body
(Current_Scope
);
10468 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10469 -- Used to suppress a single check on the given entity
10471 --------------------------------
10472 -- Suppress_Unsuppress_Echeck --
10473 --------------------------------
10475 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10477 -- Check for error of trying to set atomic synchronization for
10478 -- a non-atomic variable.
10480 if C
= Atomic_Synchronization
10481 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10484 ("pragma & requires atomic type or variable",
10485 Pragma_Identifier
(Original_Node
(N
)));
10488 Set_Checks_May_Be_Suppressed
(E
);
10490 if In_Package_Spec
then
10491 Push_Global_Suppress_Stack_Entry
10494 Suppress
=> Suppress_Case
);
10496 Push_Local_Suppress_Stack_Entry
10499 Suppress
=> Suppress_Case
);
10502 -- If this is a first subtype, and the base type is distinct,
10503 -- then also set the suppress flags on the base type.
10505 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10506 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10508 end Suppress_Unsuppress_Echeck
;
10510 -- Start of processing for Process_Suppress_Unsuppress
10513 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10514 -- on user code: we want to generate checks for analysis purposes, as
10515 -- set respectively by -gnatC and -gnatd.F
10517 if Comes_From_Source
(N
)
10518 and then (CodePeer_Mode
or GNATprove_Mode
)
10523 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10524 -- declarative part or a package spec (RM 11.5(5)).
10526 if not Is_Configuration_Pragma
then
10527 Check_Is_In_Decl_Part_Or_Package_Spec
;
10530 Check_At_Least_N_Arguments
(1);
10531 Check_At_Most_N_Arguments
(2);
10532 Check_No_Identifier
(Arg1
);
10533 Check_Arg_Is_Identifier
(Arg1
);
10535 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10537 if C
= No_Check_Id
then
10539 ("argument of pragma% is not valid check name", Arg1
);
10542 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10544 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10546 ("Suppress of Elaboration_Check ignored in SPARK??",
10547 "\elaboration checking rules are statically enforced "
10548 & "(SPARK RM 7.7)", Arg1
);
10551 -- One-argument case
10553 if Arg_Count
= 1 then
10555 -- Make an entry in the local scope suppress table. This is the
10556 -- table that directly shows the current value of the scope
10557 -- suppress check for any check id value.
10559 if C
= All_Checks
then
10561 -- For All_Checks, we set all specific predefined checks with
10562 -- the exception of Elaboration_Check, which is handled
10563 -- specially because of not wanting All_Checks to have the
10564 -- effect of deactivating static elaboration order processing.
10565 -- Atomic_Synchronization is also not affected, since this is
10566 -- not a real check.
10568 for J
in Scope_Suppress
.Suppress
'Range loop
10569 if J
/= Elaboration_Check
10571 J
/= Atomic_Synchronization
10573 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10577 -- If not All_Checks, and predefined check, then set appropriate
10578 -- scope entry. Note that we will set Elaboration_Check if this
10579 -- is explicitly specified. Atomic_Synchronization is allowed
10580 -- only if internally generated and entity is atomic.
10582 elsif C
in Predefined_Check_Id
10583 and then (not Comes_From_Source
(N
)
10584 or else C
/= Atomic_Synchronization
)
10586 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10589 -- Also make an entry in the Local_Entity_Suppress table
10591 Push_Local_Suppress_Stack_Entry
10594 Suppress
=> Suppress_Case
);
10596 -- Case of two arguments present, where the check is suppressed for
10597 -- a specified entity (given as the second argument of the pragma)
10600 -- This is obsolescent in Ada 2005 mode
10602 if Ada_Version
>= Ada_2005
then
10603 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10606 Check_Optional_Identifier
(Arg2
, Name_On
);
10607 E_Id
:= Get_Pragma_Arg
(Arg2
);
10610 if not Is_Entity_Name
(E_Id
) then
10612 ("second argument of pragma% must be entity name", Arg2
);
10615 E
:= Entity
(E_Id
);
10621 -- A pragma that applies to a Ghost entity becomes Ghost for the
10622 -- purposes of legality checks and removal of ignored Ghost code.
10624 Mark_Ghost_Pragma
(N
, E
);
10626 -- Enforce RM 11.5(7) which requires that for a pragma that
10627 -- appears within a package spec, the named entity must be
10628 -- within the package spec. We allow the package name itself
10629 -- to be mentioned since that makes sense, although it is not
10630 -- strictly allowed by 11.5(7).
10633 and then E
/= Current_Scope
10634 and then Scope
(E
) /= Current_Scope
10637 ("entity in pragma% is not in package spec (RM 11.5(7))",
10641 -- Loop through homonyms. As noted below, in the case of a package
10642 -- spec, only homonyms within the package spec are considered.
10645 Suppress_Unsuppress_Echeck
(E
, C
);
10647 if Is_Generic_Instance
(E
)
10648 and then Is_Subprogram
(E
)
10649 and then Present
(Alias
(E
))
10651 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10654 -- Move to next homonym if not aspect spec case
10656 exit when From_Aspect_Specification
(N
);
10660 -- If we are within a package specification, the pragma only
10661 -- applies to homonyms in the same scope.
10663 exit when In_Package_Spec
10664 and then Scope
(E
) /= Current_Scope
;
10667 end Process_Suppress_Unsuppress
;
10669 -------------------------------
10670 -- Record_Independence_Check --
10671 -------------------------------
10673 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10674 pragma Unreferenced
(N
, E
);
10676 -- For GCC back ends the validation is done a priori
10677 -- ??? This code is dead, might be useful in the future
10679 -- if not AAMP_On_Target then
10683 -- Independence_Checks.Append ((N, E));
10686 end Record_Independence_Check
;
10692 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10694 if Is_Imported
(E
) then
10696 ("cannot export entity& that was previously imported", Arg
);
10698 elsif Present
(Address_Clause
(E
))
10699 and then not Relaxed_RM_Semantics
10702 ("cannot export entity& that has an address clause", Arg
);
10705 Set_Is_Exported
(E
);
10707 -- Generate a reference for entity explicitly, because the
10708 -- identifier may be overloaded and name resolution will not
10711 Generate_Reference
(E
, Arg
);
10713 -- Deal with exporting non-library level entity
10715 if not Is_Library_Level_Entity
(E
) then
10717 -- Not allowed at all for subprograms
10719 if Is_Subprogram
(E
) then
10720 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10722 -- Otherwise set public and statically allocated
10726 Set_Is_Statically_Allocated
(E
);
10728 -- Warn if the corresponding W flag is set
10730 if Warn_On_Export_Import
10732 -- Only do this for something that was in the source. Not
10733 -- clear if this can be False now (there used for sure to be
10734 -- cases on some systems where it was False), but anyway the
10735 -- test is harmless if not needed, so it is retained.
10737 and then Comes_From_Source
(Arg
)
10740 ("?x?& has been made static as a result of Export",
10743 ("\?x?this usage is non-standard and non-portable",
10749 if Warn_On_Export_Import
and then Is_Type
(E
) then
10750 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10753 if Warn_On_Export_Import
and Inside_A_Generic
then
10755 ("all instances of& will have the same external name?x?",
10760 ----------------------------------------------
10761 -- Set_Extended_Import_Export_External_Name --
10762 ----------------------------------------------
10764 procedure Set_Extended_Import_Export_External_Name
10765 (Internal_Ent
: Entity_Id
;
10766 Arg_External
: Node_Id
)
10768 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10769 New_Name
: Node_Id
;
10772 if No
(Arg_External
) then
10776 Check_Arg_Is_External_Name
(Arg_External
);
10778 if Nkind
(Arg_External
) = N_String_Literal
then
10779 if String_Length
(Strval
(Arg_External
)) = 0 then
10782 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10785 elsif Nkind
(Arg_External
) = N_Identifier
then
10786 New_Name
:= Get_Default_External_Name
(Arg_External
);
10788 -- Check_Arg_Is_External_Name should let through only identifiers and
10789 -- string literals or static string expressions (which are folded to
10790 -- string literals).
10793 raise Program_Error
;
10796 -- If we already have an external name set (by a prior normal Import
10797 -- or Export pragma), then the external names must match
10799 if Present
(Interface_Name
(Internal_Ent
)) then
10801 -- Ignore mismatching names in CodePeer mode, to support some
10802 -- old compilers which would export the same procedure under
10803 -- different names, e.g:
10805 -- pragma Export_Procedure (P, "a");
10806 -- pragma Export_Procedure (P, "b");
10808 if CodePeer_Mode
then
10812 Check_Matching_Internal_Names
: declare
10813 S1
: constant String_Id
:= Strval
(Old_Name
);
10814 S2
: constant String_Id
:= Strval
(New_Name
);
10816 procedure Mismatch
;
10817 pragma No_Return
(Mismatch
);
10818 -- Called if names do not match
10824 procedure Mismatch
is
10826 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10828 ("external name does not match that given #",
10832 -- Start of processing for Check_Matching_Internal_Names
10835 if String_Length
(S1
) /= String_Length
(S2
) then
10839 for J
in 1 .. String_Length
(S1
) loop
10840 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10845 end Check_Matching_Internal_Names
;
10847 -- Otherwise set the given name
10850 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10851 Check_Duplicated_Export_Name
(New_Name
);
10853 end Set_Extended_Import_Export_External_Name
;
10859 procedure Set_Imported
(E
: Entity_Id
) is
10861 -- Error message if already imported or exported
10863 if Is_Exported
(E
) or else Is_Imported
(E
) then
10865 -- Error if being set Exported twice
10867 if Is_Exported
(E
) then
10868 Error_Msg_NE
("entity& was previously exported", N
, E
);
10870 -- Ignore error in CodePeer mode where we treat all imported
10871 -- subprograms as unknown.
10873 elsif CodePeer_Mode
then
10876 -- OK if Import/Interface case
10878 elsif Import_Interface_Present
(N
) then
10881 -- Error if being set Imported twice
10884 Error_Msg_NE
("entity& was previously imported", N
, E
);
10887 Error_Msg_Name_1
:= Pname
;
10889 ("\(pragma% applies to all previous entities)", N
);
10891 Error_Msg_Sloc
:= Sloc
(E
);
10892 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10894 -- Here if not previously imported or exported, OK to import
10897 Set_Is_Imported
(E
);
10899 -- For subprogram, set Import_Pragma field
10901 if Is_Subprogram
(E
) then
10902 Set_Import_Pragma
(E
, N
);
10905 -- If the entity is an object that is not at the library level,
10906 -- then it is statically allocated. We do not worry about objects
10907 -- with address clauses in this context since they are not really
10908 -- imported in the linker sense.
10911 and then not Is_Library_Level_Entity
(E
)
10912 and then No
(Address_Clause
(E
))
10914 Set_Is_Statically_Allocated
(E
);
10921 -------------------------
10922 -- Set_Mechanism_Value --
10923 -------------------------
10925 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10926 -- analyzed, since it is semantic nonsense), so we get it in the exact
10927 -- form created by the parser.
10929 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10930 procedure Bad_Mechanism
;
10931 pragma No_Return
(Bad_Mechanism
);
10932 -- Signal bad mechanism name
10934 -------------------
10935 -- Bad_Mechanism --
10936 -------------------
10938 procedure Bad_Mechanism
is
10940 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10943 -- Start of processing for Set_Mechanism_Value
10946 if Mechanism
(Ent
) /= Default_Mechanism
then
10948 ("mechanism for & has already been set", Mech_Name
, Ent
);
10951 -- MECHANISM_NAME ::= value | reference
10953 if Nkind
(Mech_Name
) = N_Identifier
then
10954 if Chars
(Mech_Name
) = Name_Value
then
10955 Set_Mechanism
(Ent
, By_Copy
);
10958 elsif Chars
(Mech_Name
) = Name_Reference
then
10959 Set_Mechanism
(Ent
, By_Reference
);
10962 elsif Chars
(Mech_Name
) = Name_Copy
then
10964 ("bad mechanism name, Value assumed", Mech_Name
);
10973 end Set_Mechanism_Value
;
10975 --------------------------
10976 -- Set_Rational_Profile --
10977 --------------------------
10979 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10980 -- extension to the semantics of renaming declarations.
10982 procedure Set_Rational_Profile
is
10984 Implicit_Packing
:= True;
10985 Overriding_Renamings
:= True;
10986 Use_VADS_Size
:= True;
10987 end Set_Rational_Profile
;
10989 ---------------------------
10990 -- Set_Ravenscar_Profile --
10991 ---------------------------
10993 -- The tasks to be done here are
10995 -- Set required policies
10997 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10998 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10999 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11000 -- (For GNAT_Ravenscar_EDF profile)
11001 -- pragma Locking_Policy (Ceiling_Locking)
11003 -- Set Detect_Blocking mode
11005 -- Set required restrictions (see System.Rident for detailed list)
11007 -- Set the No_Dependence rules
11008 -- No_Dependence => Ada.Asynchronous_Task_Control
11009 -- No_Dependence => Ada.Calendar
11010 -- No_Dependence => Ada.Execution_Time.Group_Budget
11011 -- No_Dependence => Ada.Execution_Time.Timers
11012 -- No_Dependence => Ada.Task_Attributes
11013 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11015 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11016 procedure Set_Error_Msg_To_Profile_Name
;
11017 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11020 -----------------------------------
11021 -- Set_Error_Msg_To_Profile_Name --
11022 -----------------------------------
11024 procedure Set_Error_Msg_To_Profile_Name
is
11025 Prof_Nam
: constant Node_Id
:=
11027 (First
(Pragma_Argument_Associations
(N
)));
11030 Get_Name_String
(Chars
(Prof_Nam
));
11031 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11032 Error_Msg_Strlen
:= Name_Len
;
11033 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11034 end Set_Error_Msg_To_Profile_Name
;
11043 Profile_Dispatching_Policy
: Character;
11045 -- Start of processing for Set_Ravenscar_Profile
11048 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11050 if Profile
= GNAT_Ravenscar_EDF
then
11051 Profile_Dispatching_Policy
:= 'E';
11053 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11056 Profile_Dispatching_Policy
:= 'F';
11059 if Task_Dispatching_Policy
/= ' '
11060 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11062 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11063 Set_Error_Msg_To_Profile_Name
;
11064 Error_Pragma
("Profile (~) incompatible with policy#");
11066 -- Set the FIFO_Within_Priorities policy, but always preserve
11067 -- System_Location since we like the error message with the run time
11071 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11073 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11074 Task_Dispatching_Policy_Sloc
:= Loc
;
11078 -- pragma Locking_Policy (Ceiling_Locking)
11080 if Locking_Policy
/= ' '
11081 and then Locking_Policy
/= 'C'
11083 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11084 Set_Error_Msg_To_Profile_Name
;
11085 Error_Pragma
("Profile (~) incompatible with policy#");
11087 -- Set the Ceiling_Locking policy, but preserve System_Location since
11088 -- we like the error message with the run time name.
11091 Locking_Policy
:= 'C';
11093 if Locking_Policy_Sloc
/= System_Location
then
11094 Locking_Policy_Sloc
:= Loc
;
11098 -- pragma Detect_Blocking
11100 Detect_Blocking
:= True;
11102 -- Set the corresponding restrictions
11104 Set_Profile_Restrictions
11105 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11107 -- Set the No_Dependence restrictions
11109 -- The following No_Dependence restrictions:
11110 -- No_Dependence => Ada.Asynchronous_Task_Control
11111 -- No_Dependence => Ada.Calendar
11112 -- No_Dependence => Ada.Task_Attributes
11113 -- are already set by previous call to Set_Profile_Restrictions.
11115 -- Set the following restrictions which were added to Ada 2005:
11116 -- No_Dependence => Ada.Execution_Time.Group_Budget
11117 -- No_Dependence => Ada.Execution_Time.Timers
11119 if Ada_Version
>= Ada_2005
then
11120 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
11121 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
11124 Make_Selected_Component
11127 Selector_Name
=> Sel_Id
);
11129 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
11132 Make_Selected_Component
11135 Selector_Name
=> Sel_Id
);
11137 Set_Restriction_No_Dependence
11139 Warn
=> Treat_Restrictions_As_Warnings
,
11140 Profile
=> Ravenscar
);
11142 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
11145 Make_Selected_Component
11148 Selector_Name
=> Sel_Id
);
11150 Set_Restriction_No_Dependence
11152 Warn
=> Treat_Restrictions_As_Warnings
,
11153 Profile
=> Ravenscar
);
11156 -- Set the following restriction which was added to Ada 2012 (see
11158 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11160 if Ada_Version
>= Ada_2012
then
11161 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
11162 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
11165 Make_Selected_Component
11168 Selector_Name
=> Sel_Id
);
11170 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
11173 Make_Selected_Component
11176 Selector_Name
=> Sel_Id
);
11178 Set_Restriction_No_Dependence
11180 Warn
=> Treat_Restrictions_As_Warnings
,
11181 Profile
=> Ravenscar
);
11183 end Set_Ravenscar_Profile
;
11185 -----------------------------------
11186 -- Validate_Acc_Condition_Clause --
11187 -----------------------------------
11189 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
) is
11191 Analyze_And_Resolve
(Clause
);
11193 if not Is_Boolean_Type
(Etype
(Clause
)) then
11194 Error_Pragma
("expected a boolean");
11196 end Validate_Acc_Condition_Clause
;
11198 ------------------------------
11199 -- Validate_Acc_Data_Clause --
11200 ------------------------------
11202 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
) is
11206 Expr
:= Acc_First
(Clause
);
11207 while Present
(Expr
) loop
11208 if Nkind
(Expr
) /= N_Identifier
then
11209 Error_Pragma
("expected an identifer");
11212 Analyze_And_Resolve
(Expr
);
11214 Expr
:= Acc_Next
(Expr
);
11216 end Validate_Acc_Data_Clause
;
11218 ----------------------------------
11219 -- Validate_Acc_Int_Expr_Clause --
11220 ----------------------------------
11222 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
) is
11224 Analyze_And_Resolve
(Clause
);
11226 if not Is_Integer_Type
(Etype
(Clause
)) then
11227 Error_Pragma_Arg
("expected an integer", Clause
);
11229 end Validate_Acc_Int_Expr_Clause
;
11231 ---------------------------------------
11232 -- Validate_Acc_Int_Expr_List_Clause --
11233 ---------------------------------------
11235 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
) is
11239 Expr
:= Acc_First
(Clause
);
11240 while Present
(Expr
) loop
11241 Analyze_And_Resolve
(Expr
);
11243 if not Is_Integer_Type
(Etype
(Expr
)) then
11244 Error_Pragma
("expected an integer");
11247 Expr
:= Acc_Next
(Expr
);
11249 end Validate_Acc_Int_Expr_List_Clause
;
11251 --------------------------------
11252 -- Validate_Acc_Loop_Collapse --
11253 --------------------------------
11255 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
) is
11257 Par_Loop
: Node_Id
;
11261 -- Make sure the argument is a positive integer
11263 Analyze_And_Resolve
(Clause
);
11265 Count
:= Static_Integer
(Clause
);
11266 if Count
= No_Uint
or else Count
< 1 then
11267 Error_Pragma_Arg
("expected a positive integer", Clause
);
11270 -- Then, make sure we have at least Count-1 tightly-nested loops
11271 -- (i.e. loops with no statements in between).
11273 Par_Loop
:= Parent
(Parent
(Parent
(Clause
)));
11274 Stmt
:= First
(Statements
(Par_Loop
));
11276 -- Skip first pragmas in the parent loop
11278 while Present
(Stmt
) and then Nkind
(Stmt
) = N_Pragma
loop
11282 if not Present
(Next
(Stmt
)) then
11283 while Nkind
(Stmt
) = N_Loop_Statement
and Count
> 1 loop
11284 Stmt
:= First
(Statements
(Stmt
));
11285 exit when Present
(Next
(Stmt
));
11287 Count
:= Count
- 1;
11293 ("Collapse argument too high or loops not tightly nested",
11296 end Validate_Acc_Loop_Collapse
;
11298 ----------------------------
11299 -- Validate_Acc_Loop_Gang --
11300 ----------------------------
11302 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
) is
11304 Error_Pragma_Arg
("Loop_Gang not implemented", Clause
);
11305 end Validate_Acc_Loop_Gang
;
11307 ------------------------------
11308 -- Validate_Acc_Loop_Vector --
11309 ------------------------------
11311 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
) is
11313 Error_Pragma_Arg
("Loop_Vector not implemented", Clause
);
11314 end Validate_Acc_Loop_Vector
;
11316 -------------------------------
11317 -- Validate_Acc_Loop_Worker --
11318 -------------------------------
11320 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
) is
11322 Error_Pragma_Arg
("Loop_Worker not implemented", Clause
);
11323 end Validate_Acc_Loop_Worker
;
11325 ---------------------------------
11326 -- Validate_Acc_Name_Reduction --
11327 ---------------------------------
11329 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
) is
11331 -- ??? On top of the following operations, the OpenAcc spec adds the
11332 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11333 -- ".neqv" for Fortran. Can we, should we and how do we support them
11336 type Reduction_Op
is (Add_Op
, Mul_Op
, Max_Op
, Min_Op
, And_Op
, Or_Op
);
11338 function To_Reduction_Op
(Op
: String) return Reduction_Op
;
11339 -- Convert operator Op described by a String into its corresponding
11340 -- enumeration value.
11342 ---------------------
11343 -- To_Reduction_Op --
11344 ---------------------
11346 function To_Reduction_Op
(Op
: String) return Reduction_Op
is
11351 elsif Op
= "*" then
11354 elsif Op
= "max" then
11357 elsif Op
= "min" then
11360 elsif Op
= "and" then
11363 elsif Op
= "or" then
11367 Error_Pragma
("unsuported reduction operation");
11369 end To_Reduction_Op
;
11373 Seen
: constant Elist_Id
:= New_Elmt_List
;
11376 Reduc_Op
: Node_Id
;
11377 Reduc_Var
: Node_Id
;
11379 -- Start of processing for Validate_Acc_Name_Reduction
11382 -- Reduction operations appear in the following form:
11383 -- ("+" => (a, b), "*" => c)
11385 Expr
:= First
(Component_Associations
(Clause
));
11386 while Present
(Expr
) loop
11387 Reduc_Op
:= First
(Choices
(Expr
));
11388 String_To_Name_Buffer
(Strval
(Reduc_Op
));
11390 case To_Reduction_Op
(Name_Buffer
(1 .. Name_Len
)) is
11396 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11397 while Present
(Reduc_Var
) loop
11398 Analyze_And_Resolve
(Reduc_Var
);
11400 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11401 Error_Pragma
("variable used in multiple reductions");
11404 if Nkind
(Reduc_Var
) /= N_Identifier
11405 or not Is_Numeric_Type
(Etype
(Reduc_Var
))
11408 ("expected an identifier for a Numeric");
11411 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11414 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11420 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11421 while Present
(Reduc_Var
) loop
11422 Analyze_And_Resolve
(Reduc_Var
);
11424 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11425 Error_Pragma
("variable used in multiple reductions");
11428 if Nkind
(Reduc_Var
) /= N_Identifier
11429 or not Is_Boolean_Type
(Etype
(Reduc_Var
))
11432 ("expected a variable of type boolean");
11435 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11438 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11444 end Validate_Acc_Name_Reduction
;
11446 -----------------------------------
11447 -- Validate_Acc_Size_Expressions --
11448 -----------------------------------
11450 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
) is
11451 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean;
11452 -- A size expr is either an integer expression or "*"
11454 ------------------------
11455 -- Validate_Size_Expr --
11456 ------------------------
11458 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean is
11460 if Nkind
(Expr
) = N_Operator_Symbol
then
11461 return Get_String_Char
(Strval
(Expr
), 1) = Get_Char_Code
('*');
11464 Analyze_And_Resolve
(Expr
);
11466 return Is_Integer_Type
(Etype
(Expr
));
11467 end Validate_Size_Expr
;
11473 -- Start of processing for Validate_Acc_Size_Expressions
11476 Expr
:= Acc_First
(Clause
);
11477 while Present
(Expr
) loop
11478 if not Validate_Size_Expr
(Expr
) then
11480 ("Size expressions should be either integers or '*'");
11483 Expr
:= Acc_Next
(Expr
);
11485 end Validate_Acc_Size_Expressions
;
11487 -- Start of processing for Analyze_Pragma
11490 -- The following code is a defense against recursion. Not clear that
11491 -- this can happen legitimately, but perhaps some error situations can
11492 -- cause it, and we did see this recursion during testing.
11494 if Analyzed
(N
) then
11500 Check_Restriction_No_Use_Of_Pragma
(N
);
11502 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11503 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11505 if Should_Ignore_Pragma_Sem
(N
)
11506 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11507 and then Ignore_Rep_Clauses
)
11512 -- Deal with unrecognized pragma
11514 if not Is_Pragma_Name
(Pname
) then
11515 if Warn_On_Unrecognized_Pragma
then
11516 Error_Msg_Name_1
:= Pname
;
11517 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11519 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11520 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11521 Error_Msg_Name_1
:= PN
;
11522 Error_Msg_N
-- CODEFIX
11523 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11532 -- Here to start processing for recognized pragma
11534 Pname
:= Original_Aspect_Pragma_Name
(N
);
11536 -- Capture setting of Opt.Uneval_Old
11538 case Opt
.Uneval_Old
is
11540 Set_Uneval_Old_Accept
(N
);
11546 Set_Uneval_Old_Warn
(N
);
11549 raise Program_Error
;
11552 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11553 -- is already set, indicating that we have already checked the policy
11554 -- at the right point. This happens for example in the case of a pragma
11555 -- that is derived from an Aspect.
11557 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11560 -- For a pragma that is a rewriting of another pragma, copy the
11561 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11563 elsif Is_Rewrite_Substitution
(N
)
11564 and then Nkind
(Original_Node
(N
)) = N_Pragma
11566 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11567 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11569 -- Otherwise query the applicable policy at this point
11572 Check_Applicable_Policy
(N
);
11574 -- If pragma is disabled, rewrite as NULL and skip analysis
11576 if Is_Disabled
(N
) then
11577 Rewrite
(N
, Make_Null_Statement
(Loc
));
11583 -- Preset arguments
11591 if Present
(Pragma_Argument_Associations
(N
)) then
11592 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11593 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11595 if Present
(Arg1
) then
11596 Arg2
:= Next
(Arg1
);
11598 if Present
(Arg2
) then
11599 Arg3
:= Next
(Arg2
);
11601 if Present
(Arg3
) then
11602 Arg4
:= Next
(Arg3
);
11608 -- An enumeration type defines the pragmas that are supported by the
11609 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11610 -- into the corresponding enumeration value for the following case.
11618 -- pragma Abort_Defer;
11620 when Pragma_Abort_Defer
=>
11622 Check_Arg_Count
(0);
11624 -- The only required semantic processing is to check the
11625 -- placement. This pragma must appear at the start of the
11626 -- statement sequence of a handled sequence of statements.
11628 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11629 or else N
/= First
(Statements
(Parent
(N
)))
11634 --------------------
11635 -- Abstract_State --
11636 --------------------
11638 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11640 -- ABSTRACT_STATE_LIST ::=
11642 -- | STATE_NAME_WITH_OPTIONS
11643 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11645 -- STATE_NAME_WITH_OPTIONS ::=
11647 -- | (STATE_NAME with OPTION_LIST)
11649 -- OPTION_LIST ::= OPTION {, OPTION}
11653 -- | NAME_VALUE_OPTION
11655 -- SIMPLE_OPTION ::= Ghost | Synchronous
11657 -- NAME_VALUE_OPTION ::=
11658 -- Part_Of => ABSTRACT_STATE
11659 -- | External [=> EXTERNAL_PROPERTY_LIST]
11661 -- EXTERNAL_PROPERTY_LIST ::=
11662 -- EXTERNAL_PROPERTY
11663 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11665 -- EXTERNAL_PROPERTY ::=
11666 -- Async_Readers [=> boolean_EXPRESSION]
11667 -- | Async_Writers [=> boolean_EXPRESSION]
11668 -- | Effective_Reads [=> boolean_EXPRESSION]
11669 -- | Effective_Writes [=> boolean_EXPRESSION]
11670 -- others => boolean_EXPRESSION
11672 -- STATE_NAME ::= defining_identifier
11674 -- ABSTRACT_STATE ::= name
11676 -- Characteristics:
11678 -- * Analysis - The annotation is fully analyzed immediately upon
11679 -- elaboration as it cannot forward reference entities.
11681 -- * Expansion - None.
11683 -- * Template - The annotation utilizes the generic template of the
11684 -- related package declaration.
11686 -- * Globals - The annotation cannot reference global entities.
11688 -- * Instance - The annotation is instantiated automatically when
11689 -- the related generic package is instantiated.
11691 when Pragma_Abstract_State
=> Abstract_State
: declare
11692 Missing_Parentheses
: Boolean := False;
11693 -- Flag set when a state declaration with options is not properly
11696 -- Flags used to verify the consistency of states
11698 Non_Null_Seen
: Boolean := False;
11699 Null_Seen
: Boolean := False;
11701 procedure Analyze_Abstract_State
11703 Pack_Id
: Entity_Id
);
11704 -- Verify the legality of a single state declaration. Create and
11705 -- decorate a state abstraction entity and introduce it into the
11706 -- visibility chain. Pack_Id denotes the entity or the related
11707 -- package where pragma Abstract_State appears.
11709 procedure Malformed_State_Error
(State
: Node_Id
);
11710 -- Emit an error concerning the illegal declaration of abstract
11711 -- state State. This routine diagnoses syntax errors that lead to
11712 -- a different parse tree. The error is issued regardless of the
11713 -- SPARK mode in effect.
11715 ----------------------------
11716 -- Analyze_Abstract_State --
11717 ----------------------------
11719 procedure Analyze_Abstract_State
11721 Pack_Id
: Entity_Id
)
11723 -- Flags used to verify the consistency of options
11725 AR_Seen
: Boolean := False;
11726 AW_Seen
: Boolean := False;
11727 ER_Seen
: Boolean := False;
11728 EW_Seen
: Boolean := False;
11729 External_Seen
: Boolean := False;
11730 Ghost_Seen
: Boolean := False;
11731 Others_Seen
: Boolean := False;
11732 Part_Of_Seen
: Boolean := False;
11733 Synchronous_Seen
: Boolean := False;
11735 -- Flags used to store the static value of all external states'
11738 AR_Val
: Boolean := False;
11739 AW_Val
: Boolean := False;
11740 ER_Val
: Boolean := False;
11741 EW_Val
: Boolean := False;
11743 State_Id
: Entity_Id
:= Empty
;
11744 -- The entity to be generated for the current state declaration
11746 procedure Analyze_External_Option
(Opt
: Node_Id
);
11747 -- Verify the legality of option External
11749 procedure Analyze_External_Property
11751 Expr
: Node_Id
:= Empty
);
11752 -- Verify the legailty of a single external property. Prop
11753 -- denotes the external property. Expr is the expression used
11754 -- to set the property.
11756 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11757 -- Verify the legality of option Part_Of
11759 procedure Check_Duplicate_Option
11761 Status
: in out Boolean);
11762 -- Flag Status denotes whether a particular option has been
11763 -- seen while processing a state. This routine verifies that
11764 -- Opt is not a duplicate option and sets the flag Status
11765 -- (SPARK RM 7.1.4(1)).
11767 procedure Check_Duplicate_Property
11769 Status
: in out Boolean);
11770 -- Flag Status denotes whether a particular property has been
11771 -- seen while processing option External. This routine verifies
11772 -- that Prop is not a duplicate property and sets flag Status.
11773 -- Opt is not a duplicate property and sets the flag Status.
11774 -- (SPARK RM 7.1.4(2))
11776 procedure Check_Ghost_Synchronous
;
11777 -- Ensure that the abstract state is not subject to both Ghost
11778 -- and Synchronous simple options. Emit an error if this is the
11781 procedure Create_Abstract_State
11785 Is_Null
: Boolean);
11786 -- Generate an abstract state entity with name Nam and enter it
11787 -- into visibility. Decl is the "declaration" of the state as
11788 -- it appears in pragma Abstract_State. Loc is the location of
11789 -- the related state "declaration". Flag Is_Null should be set
11790 -- when the associated Abstract_State pragma defines a null
11793 -----------------------------
11794 -- Analyze_External_Option --
11795 -----------------------------
11797 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11798 Errors
: constant Nat
:= Serious_Errors_Detected
;
11800 Props
: Node_Id
:= Empty
;
11803 if Nkind
(Opt
) = N_Component_Association
then
11804 Props
:= Expression
(Opt
);
11807 -- External state with properties
11809 if Present
(Props
) then
11811 -- Multiple properties appear as an aggregate
11813 if Nkind
(Props
) = N_Aggregate
then
11815 -- Simple property form
11817 Prop
:= First
(Expressions
(Props
));
11818 while Present
(Prop
) loop
11819 Analyze_External_Property
(Prop
);
11823 -- Property with expression form
11825 Prop
:= First
(Component_Associations
(Props
));
11826 while Present
(Prop
) loop
11827 Analyze_External_Property
11828 (Prop
=> First
(Choices
(Prop
)),
11829 Expr
=> Expression
(Prop
));
11837 Analyze_External_Property
(Props
);
11840 -- An external state defined without any properties defaults
11841 -- all properties to True.
11850 -- Once all external properties have been processed, verify
11851 -- their mutual interaction. Do not perform the check when
11852 -- at least one of the properties is illegal as this will
11853 -- produce a bogus error.
11855 if Errors
= Serious_Errors_Detected
then
11856 Check_External_Properties
11857 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11859 end Analyze_External_Option
;
11861 -------------------------------
11862 -- Analyze_External_Property --
11863 -------------------------------
11865 procedure Analyze_External_Property
11867 Expr
: Node_Id
:= Empty
)
11869 Expr_Val
: Boolean;
11872 -- Check the placement of "others" (if available)
11874 if Nkind
(Prop
) = N_Others_Choice
then
11875 if Others_Seen
then
11877 ("only one others choice allowed in option External",
11880 Others_Seen
:= True;
11883 elsif Others_Seen
then
11885 ("others must be the last property in option External",
11888 -- The only remaining legal options are the four predefined
11889 -- external properties.
11891 elsif Nkind
(Prop
) = N_Identifier
11892 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11893 Name_Async_Writers
,
11894 Name_Effective_Reads
,
11895 Name_Effective_Writes
)
11899 -- Otherwise the construct is not a valid property
11902 SPARK_Msg_N
("invalid external state property", Prop
);
11906 -- Ensure that the expression of the external state property
11907 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11909 if Present
(Expr
) then
11910 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11912 if Is_OK_Static_Expression
(Expr
) then
11913 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11916 ("expression of external state property must be "
11921 -- The lack of expression defaults the property to True
11927 -- Named properties
11929 if Nkind
(Prop
) = N_Identifier
then
11930 if Chars
(Prop
) = Name_Async_Readers
then
11931 Check_Duplicate_Property
(Prop
, AR_Seen
);
11932 AR_Val
:= Expr_Val
;
11934 elsif Chars
(Prop
) = Name_Async_Writers
then
11935 Check_Duplicate_Property
(Prop
, AW_Seen
);
11936 AW_Val
:= Expr_Val
;
11938 elsif Chars
(Prop
) = Name_Effective_Reads
then
11939 Check_Duplicate_Property
(Prop
, ER_Seen
);
11940 ER_Val
:= Expr_Val
;
11943 Check_Duplicate_Property
(Prop
, EW_Seen
);
11944 EW_Val
:= Expr_Val
;
11947 -- The handling of property "others" must take into account
11948 -- all other named properties that have been encountered so
11949 -- far. Only those that have not been seen are affected by
11953 if not AR_Seen
then
11954 AR_Val
:= Expr_Val
;
11957 if not AW_Seen
then
11958 AW_Val
:= Expr_Val
;
11961 if not ER_Seen
then
11962 ER_Val
:= Expr_Val
;
11965 if not EW_Seen
then
11966 EW_Val
:= Expr_Val
;
11969 end Analyze_External_Property
;
11971 ----------------------------
11972 -- Analyze_Part_Of_Option --
11973 ----------------------------
11975 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11976 Encap
: constant Node_Id
:= Expression
(Opt
);
11977 Constits
: Elist_Id
;
11978 Encap_Id
: Entity_Id
;
11982 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11985 (Indic
=> First
(Choices
(Opt
)),
11986 Item_Id
=> State_Id
,
11988 Encap_Id
=> Encap_Id
,
11991 -- The Part_Of indicator transforms the abstract state into
11992 -- a constituent of the encapsulating state or single
11993 -- concurrent type.
11996 pragma Assert
(Present
(Encap_Id
));
11997 Constits
:= Part_Of_Constituents
(Encap_Id
);
11999 if No
(Constits
) then
12000 Constits
:= New_Elmt_List
;
12001 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12004 Append_Elmt
(State_Id
, Constits
);
12005 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12007 end Analyze_Part_Of_Option
;
12009 ----------------------------
12010 -- Check_Duplicate_Option --
12011 ----------------------------
12013 procedure Check_Duplicate_Option
12015 Status
: in out Boolean)
12019 SPARK_Msg_N
("duplicate state option", Opt
);
12023 end Check_Duplicate_Option
;
12025 ------------------------------
12026 -- Check_Duplicate_Property --
12027 ------------------------------
12029 procedure Check_Duplicate_Property
12031 Status
: in out Boolean)
12035 SPARK_Msg_N
("duplicate external property", Prop
);
12039 end Check_Duplicate_Property
;
12041 -----------------------------
12042 -- Check_Ghost_Synchronous --
12043 -----------------------------
12045 procedure Check_Ghost_Synchronous
is
12047 -- A synchronized abstract state cannot be Ghost and vice
12048 -- versa (SPARK RM 6.9(19)).
12050 if Ghost_Seen
and Synchronous_Seen
then
12051 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12053 end Check_Ghost_Synchronous
;
12055 ---------------------------
12056 -- Create_Abstract_State --
12057 ---------------------------
12059 procedure Create_Abstract_State
12066 -- The abstract state may be semi-declared when the related
12067 -- package was withed through a limited with clause. In that
12068 -- case reuse the entity to fully declare the state.
12070 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12071 State_Id
:= Entity
(Decl
);
12073 -- Otherwise the elaboration of pragma Abstract_State
12074 -- declares the state.
12077 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12079 if Present
(Decl
) then
12080 Set_Entity
(Decl
, State_Id
);
12084 -- Null states never come from source
12086 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12087 Set_Parent
(State_Id
, State
);
12088 Set_Ekind
(State_Id
, E_Abstract_State
);
12089 Set_Etype
(State_Id
, Standard_Void_Type
);
12090 Set_Encapsulating_State
(State_Id
, Empty
);
12092 -- Set the SPARK mode from the current context
12094 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12095 Set_SPARK_Pragma_Inherited
(State_Id
);
12097 -- An abstract state declared within a Ghost region becomes
12098 -- Ghost (SPARK RM 6.9(2)).
12100 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12101 Set_Is_Ghost_Entity
(State_Id
);
12104 -- Establish a link between the state declaration and the
12105 -- abstract state entity. Note that a null state remains as
12106 -- N_Null and does not carry any linkages.
12108 if not Is_Null
then
12109 if Present
(Decl
) then
12110 Set_Entity
(Decl
, State_Id
);
12111 Set_Etype
(Decl
, Standard_Void_Type
);
12114 -- Every non-null state must be defined, nameable and
12117 Push_Scope
(Pack_Id
);
12118 Generate_Definition
(State_Id
);
12119 Enter_Name
(State_Id
);
12122 end Create_Abstract_State
;
12129 -- Start of processing for Analyze_Abstract_State
12132 -- A package with a null abstract state is not allowed to
12133 -- declare additional states.
12137 ("package & has null abstract state", State
, Pack_Id
);
12139 -- Null states appear as internally generated entities
12141 elsif Nkind
(State
) = N_Null
then
12142 Create_Abstract_State
12143 (Nam
=> New_Internal_Name
('S'),
12145 Loc
=> Sloc
(State
),
12149 -- Catch a case where a null state appears in a list of
12150 -- non-null states.
12152 if Non_Null_Seen
then
12154 ("package & has non-null abstract state",
12158 -- Simple state declaration
12160 elsif Nkind
(State
) = N_Identifier
then
12161 Create_Abstract_State
12162 (Nam
=> Chars
(State
),
12164 Loc
=> Sloc
(State
),
12166 Non_Null_Seen
:= True;
12168 -- State declaration with various options. This construct
12169 -- appears as an extension aggregate in the tree.
12171 elsif Nkind
(State
) = N_Extension_Aggregate
then
12172 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12173 Create_Abstract_State
12174 (Nam
=> Chars
(Ancestor_Part
(State
)),
12175 Decl
=> Ancestor_Part
(State
),
12176 Loc
=> Sloc
(Ancestor_Part
(State
)),
12178 Non_Null_Seen
:= True;
12181 ("state name must be an identifier",
12182 Ancestor_Part
(State
));
12185 -- Options External, Ghost and Synchronous appear as
12188 Opt
:= First
(Expressions
(State
));
12189 while Present
(Opt
) loop
12190 if Nkind
(Opt
) = N_Identifier
then
12194 if Chars
(Opt
) = Name_External
then
12195 Check_Duplicate_Option
(Opt
, External_Seen
);
12196 Analyze_External_Option
(Opt
);
12200 elsif Chars
(Opt
) = Name_Ghost
then
12201 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12202 Check_Ghost_Synchronous
;
12204 if Present
(State_Id
) then
12205 Set_Is_Ghost_Entity
(State_Id
);
12210 elsif Chars
(Opt
) = Name_Synchronous
then
12211 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12212 Check_Ghost_Synchronous
;
12214 -- Option Part_Of without an encapsulating state is
12215 -- illegal (SPARK RM 7.1.4(9)).
12217 elsif Chars
(Opt
) = Name_Part_Of
then
12219 ("indicator Part_Of must denote abstract state, "
12220 & "single protected type or single task type",
12223 -- Do not emit an error message when a previous state
12224 -- declaration with options was not parenthesized as
12225 -- the option is actually another state declaration.
12227 -- with Abstract_State
12228 -- (State_1 with ..., -- missing parentheses
12229 -- (State_2 with ...),
12230 -- State_3) -- ok state declaration
12232 elsif Missing_Parentheses
then
12235 -- Otherwise the option is not allowed. Note that it
12236 -- is not possible to distinguish between an option
12237 -- and a state declaration when a previous state with
12238 -- options not properly parentheses.
12240 -- with Abstract_State
12241 -- (State_1 with ..., -- missing parentheses
12242 -- State_2); -- could be an option
12246 ("simple option not allowed in state declaration",
12250 -- Catch a case where missing parentheses around a state
12251 -- declaration with options cause a subsequent state
12252 -- declaration with options to be treated as an option.
12254 -- with Abstract_State
12255 -- (State_1 with ..., -- missing parentheses
12256 -- (State_2 with ...))
12258 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12259 Missing_Parentheses
:= True;
12261 ("state declaration must be parenthesized",
12262 Ancestor_Part
(State
));
12264 -- Otherwise the option is malformed
12267 SPARK_Msg_N
("malformed option", Opt
);
12273 -- Options External and Part_Of appear as component
12276 Opt
:= First
(Component_Associations
(State
));
12277 while Present
(Opt
) loop
12278 Opt_Nam
:= First
(Choices
(Opt
));
12280 if Nkind
(Opt_Nam
) = N_Identifier
then
12281 if Chars
(Opt_Nam
) = Name_External
then
12282 Analyze_External_Option
(Opt
);
12284 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12285 Analyze_Part_Of_Option
(Opt
);
12288 SPARK_Msg_N
("invalid state option", Opt
);
12291 SPARK_Msg_N
("invalid state option", Opt
);
12297 -- Any other attempt to declare a state is illegal
12300 Malformed_State_Error
(State
);
12304 -- Guard against a junk state. In such cases no entity is
12305 -- generated and the subsequent checks cannot be applied.
12307 if Present
(State_Id
) then
12309 -- Verify whether the state does not introduce an illegal
12310 -- hidden state within a package subject to a null abstract
12313 Check_No_Hidden_State
(State_Id
);
12315 -- Check whether the lack of option Part_Of agrees with the
12316 -- placement of the abstract state with respect to the state
12319 if not Part_Of_Seen
then
12320 Check_Missing_Part_Of
(State_Id
);
12323 -- Associate the state with its related package
12325 if No
(Abstract_States
(Pack_Id
)) then
12326 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12329 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12331 end Analyze_Abstract_State
;
12333 ---------------------------
12334 -- Malformed_State_Error --
12335 ---------------------------
12337 procedure Malformed_State_Error
(State
: Node_Id
) is
12339 Error_Msg_N
("malformed abstract state declaration", State
);
12341 -- An abstract state with a simple option is being declared
12342 -- with "=>" rather than the legal "with". The state appears
12343 -- as a component association.
12345 if Nkind
(State
) = N_Component_Association
then
12346 Error_Msg_N
("\use WITH to specify simple option", State
);
12348 end Malformed_State_Error
;
12352 Pack_Decl
: Node_Id
;
12353 Pack_Id
: Entity_Id
;
12357 -- Start of processing for Abstract_State
12361 Check_No_Identifiers
;
12362 Check_Arg_Count
(1);
12364 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12366 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
12367 N_Package_Declaration
)
12373 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12375 -- A pragma that applies to a Ghost entity becomes Ghost for the
12376 -- purposes of legality checks and removal of ignored Ghost code.
12378 Mark_Ghost_Pragma
(N
, Pack_Id
);
12379 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12381 -- Chain the pragma on the contract for completeness
12383 Add_Contract_Item
(N
, Pack_Id
);
12385 -- The legality checks of pragmas Abstract_State, Initializes, and
12386 -- Initial_Condition are affected by the SPARK mode in effect. In
12387 -- addition, these three pragmas are subject to an inherent order:
12389 -- 1) Abstract_State
12391 -- 3) Initial_Condition
12393 -- Analyze all these pragmas in the order outlined above
12395 Analyze_If_Present
(Pragma_SPARK_Mode
);
12396 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12398 -- Multiple non-null abstract states appear as an aggregate
12400 if Nkind
(States
) = N_Aggregate
then
12401 State
:= First
(Expressions
(States
));
12402 while Present
(State
) loop
12403 Analyze_Abstract_State
(State
, Pack_Id
);
12407 -- An abstract state with a simple option is being illegaly
12408 -- declared with "=>" rather than "with". In this case the
12409 -- state declaration appears as a component association.
12411 if Present
(Component_Associations
(States
)) then
12412 State
:= First
(Component_Associations
(States
));
12413 while Present
(State
) loop
12414 Malformed_State_Error
(State
);
12419 -- Various forms of a single abstract state. Note that these may
12420 -- include malformed state declarations.
12423 Analyze_Abstract_State
(States
, Pack_Id
);
12426 Analyze_If_Present
(Pragma_Initializes
);
12427 Analyze_If_Present
(Pragma_Initial_Condition
);
12428 end Abstract_State
;
12434 when Pragma_Acc_Data
=> Acc_Data
: declare
12435 Clause_Names
: constant Name_List
:=
12448 Clauses
: Args_List
(Clause_Names
'Range);
12451 if not OpenAcc_Enabled
then
12457 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12459 ("Acc_Data pragma should be placed in loop or block "
12463 Gather_Associations
(Clause_Names
, Clauses
);
12465 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12466 Clause
:= Clauses
(Id
);
12468 if Present
(Clause
) then
12469 case Clause_Names
(Id
) is
12477 Validate_Acc_Data_Clause
(Clause
);
12484 Error_Pragma
("unsupported pragma clause");
12487 raise Program_Error
;
12492 Set_Is_OpenAcc_Environment
(Parent
(N
));
12499 when Pragma_Acc_Loop
=> Acc_Loop
: declare
12500 Clause_Names
: constant Name_List
:=
12513 Clauses
: Args_List
(Clause_Names
'Range);
12517 if not OpenAcc_Enabled
then
12523 -- Make sure the pragma is in an openacc construct
12525 Check_Loop_Pragma_Placement
;
12528 while Present
(Par
)
12529 and then (Nkind
(Par
) /= N_Loop_Statement
12530 or else not Is_OpenAcc_Environment
(Par
))
12532 Par
:= Parent
(Par
);
12535 if not Is_OpenAcc_Environment
(Par
) then
12537 ("Acc_Loop directive must be associated with an OpenAcc "
12538 & "construct region");
12541 Gather_Associations
(Clause_Names
, Clauses
);
12543 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12544 Clause
:= Clauses
(Id
);
12546 if Present
(Clause
) then
12547 case Clause_Names
(Id
) is
12554 when Name_Collapse
=>
12555 Validate_Acc_Loop_Collapse
(Clause
);
12558 Validate_Acc_Loop_Gang
(Clause
);
12560 when Name_Acc_Private
=>
12561 Validate_Acc_Data_Clause
(Clause
);
12563 when Name_Reduction
=>
12564 Validate_Acc_Name_Reduction
(Clause
);
12567 Validate_Acc_Size_Expressions
(Clause
);
12569 when Name_Vector
=>
12570 Validate_Acc_Loop_Vector
(Clause
);
12572 when Name_Worker
=>
12573 Validate_Acc_Loop_Worker
(Clause
);
12576 raise Program_Error
;
12581 Set_Is_OpenAcc_Loop
(Parent
(N
));
12584 ----------------------------------
12585 -- Acc_Parallel and Acc_Kernels --
12586 ----------------------------------
12588 when Pragma_Acc_Parallel
12589 | Pragma_Acc_Kernels
12591 Acc_Kernels_Or_Parallel
: declare
12592 Clause_Names
: constant Name_List
:=
12605 Name_Vector_Length
,
12611 Name_First_Private
,
12620 Clauses
: Args_List
(Clause_Names
'Range);
12623 if not OpenAcc_Enabled
then
12628 Check_Loop_Pragma_Placement
;
12630 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12632 ("pragma should be placed in loop or block statements");
12635 Gather_Associations
(Clause_Names
, Clauses
);
12637 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12638 Clause
:= Clauses
(Id
);
12640 if Present
(Clause
) then
12641 if Chars
(Parent
(Clause
)) = No_Name
then
12642 Error_Pragma
("all arguments should be associations");
12644 case Clause_Names
(Id
) is
12646 -- Note: According to the OpenAcc Standard v2.6,
12647 -- Async's argument should be optional. Because this
12648 -- complicates parsing the clause, the argument is
12649 -- made mandatory. The standard defines two negative
12650 -- values, acc_async_noval and acc_async_sync. When
12651 -- given acc_async_noval as value, the clause should
12652 -- behave as if no argument was given. According to
12653 -- the standard, acc_async_noval is defined in header
12654 -- files for C and Fortran, thus this value should
12655 -- probably be defined in the OpenAcc Ada library once
12656 -- it is implemented.
12661 | Name_Vector_Length
12663 Validate_Acc_Int_Expr_Clause
(Clause
);
12665 when Name_Acc_If
=>
12666 Validate_Acc_Condition_Clause
(Clause
);
12668 -- Unsupported by GCC
12673 Error_Pragma
("unsupported clause");
12675 when Name_Acc_Private
12676 | Name_First_Private
12678 if Prag_Id
/= Pragma_Acc_Parallel
then
12680 ("argument is only available for 'Parallel' "
12683 Validate_Acc_Data_Clause
(Clause
);
12693 Validate_Acc_Data_Clause
(Clause
);
12695 when Name_Reduction
=>
12696 if Prag_Id
/= Pragma_Acc_Parallel
then
12698 ("argument is only available for 'Parallel' "
12701 Validate_Acc_Name_Reduction
(Clause
);
12704 when Name_Default
=>
12705 if Chars
(Clause
) /= Name_None
then
12706 Error_Pragma
("expected none");
12709 when Name_Device_Type
=>
12710 Error_Pragma
("unsupported pragma clause");
12712 -- Similar to Name_Async, Name_Wait's arguments should
12713 -- be optional. However, this can be simulated using
12714 -- acc_async_noval, hence, we do not bother making the
12715 -- argument optional for now.
12718 Validate_Acc_Int_Expr_List_Clause
(Clause
);
12721 raise Program_Error
;
12727 Set_Is_OpenAcc_Environment
(Parent
(N
));
12728 end Acc_Kernels_Or_Parallel
;
12736 -- Note: this pragma also has some specific processing in Par.Prag
12737 -- because we want to set the Ada version mode during parsing.
12739 when Pragma_Ada_83
=>
12741 Check_Arg_Count
(0);
12743 -- We really should check unconditionally for proper configuration
12744 -- pragma placement, since we really don't want mixed Ada modes
12745 -- within a single unit, and the GNAT reference manual has always
12746 -- said this was a configuration pragma, but we did not check and
12747 -- are hesitant to add the check now.
12749 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12750 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12751 -- or Ada 2012 mode.
12753 if Ada_Version
>= Ada_2005
then
12754 Check_Valid_Configuration_Pragma
;
12757 -- Now set Ada 83 mode
12759 if Latest_Ada_Only
then
12760 Error_Pragma
("??pragma% ignored");
12762 Ada_Version
:= Ada_83
;
12763 Ada_Version_Explicit
:= Ada_83
;
12764 Ada_Version_Pragma
:= N
;
12773 -- Note: this pragma also has some specific processing in Par.Prag
12774 -- because we want to set the Ada 83 version mode during parsing.
12776 when Pragma_Ada_95
=>
12778 Check_Arg_Count
(0);
12780 -- We really should check unconditionally for proper configuration
12781 -- pragma placement, since we really don't want mixed Ada modes
12782 -- within a single unit, and the GNAT reference manual has always
12783 -- said this was a configuration pragma, but we did not check and
12784 -- are hesitant to add the check now.
12786 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12787 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12789 if Ada_Version
>= Ada_2005
then
12790 Check_Valid_Configuration_Pragma
;
12793 -- Now set Ada 95 mode
12795 if Latest_Ada_Only
then
12796 Error_Pragma
("??pragma% ignored");
12798 Ada_Version
:= Ada_95
;
12799 Ada_Version_Explicit
:= Ada_95
;
12800 Ada_Version_Pragma
:= N
;
12803 ---------------------
12804 -- Ada_05/Ada_2005 --
12805 ---------------------
12808 -- pragma Ada_05 (LOCAL_NAME);
12810 -- pragma Ada_2005;
12811 -- pragma Ada_2005 (LOCAL_NAME):
12813 -- Note: these pragmas also have some specific processing in Par.Prag
12814 -- because we want to set the Ada 2005 version mode during parsing.
12816 -- The one argument form is used for managing the transition from
12817 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12818 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12819 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12820 -- mode, a preference rule is established which does not choose
12821 -- such an entity unless it is unambiguously specified. This avoids
12822 -- extra subprograms marked this way from generating ambiguities in
12823 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12824 -- intended for exclusive use in the GNAT run-time library.
12835 if Arg_Count
= 1 then
12836 Check_Arg_Is_Local_Name
(Arg1
);
12837 E_Id
:= Get_Pragma_Arg
(Arg1
);
12839 if Etype
(E_Id
) = Any_Type
then
12843 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12844 Record_Rep_Item
(Entity
(E_Id
), N
);
12847 Check_Arg_Count
(0);
12849 -- For Ada_2005 we unconditionally enforce the documented
12850 -- configuration pragma placement, since we do not want to
12851 -- tolerate mixed modes in a unit involving Ada 2005. That
12852 -- would cause real difficulties for those cases where there
12853 -- are incompatibilities between Ada 95 and Ada 2005.
12855 Check_Valid_Configuration_Pragma
;
12857 -- Now set appropriate Ada mode
12859 if Latest_Ada_Only
then
12860 Error_Pragma
("??pragma% ignored");
12862 Ada_Version
:= Ada_2005
;
12863 Ada_Version_Explicit
:= Ada_2005
;
12864 Ada_Version_Pragma
:= N
;
12869 ---------------------
12870 -- Ada_12/Ada_2012 --
12871 ---------------------
12874 -- pragma Ada_12 (LOCAL_NAME);
12876 -- pragma Ada_2012;
12877 -- pragma Ada_2012 (LOCAL_NAME):
12879 -- Note: these pragmas also have some specific processing in Par.Prag
12880 -- because we want to set the Ada 2012 version mode during parsing.
12882 -- The one argument form is used for managing the transition from Ada
12883 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12884 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12885 -- mode will generate a warning. In addition, in any pre-Ada_2012
12886 -- mode, a preference rule is established which does not choose
12887 -- such an entity unless it is unambiguously specified. This avoids
12888 -- extra subprograms marked this way from generating ambiguities in
12889 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12890 -- intended for exclusive use in the GNAT run-time library.
12901 if Arg_Count
= 1 then
12902 Check_Arg_Is_Local_Name
(Arg1
);
12903 E_Id
:= Get_Pragma_Arg
(Arg1
);
12905 if Etype
(E_Id
) = Any_Type
then
12909 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12910 Record_Rep_Item
(Entity
(E_Id
), N
);
12913 Check_Arg_Count
(0);
12915 -- For Ada_2012 we unconditionally enforce the documented
12916 -- configuration pragma placement, since we do not want to
12917 -- tolerate mixed modes in a unit involving Ada 2012. That
12918 -- would cause real difficulties for those cases where there
12919 -- are incompatibilities between Ada 95 and Ada 2012. We could
12920 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12922 Check_Valid_Configuration_Pragma
;
12924 -- Now set appropriate Ada mode
12926 Ada_Version
:= Ada_2012
;
12927 Ada_Version_Explicit
:= Ada_2012
;
12928 Ada_Version_Pragma
:= N
;
12936 -- pragma Ada_2020;
12938 -- Note: this pragma also has some specific processing in Par.Prag
12939 -- because we want to set the Ada 2020 version mode during parsing.
12941 when Pragma_Ada_2020
=>
12944 Check_Arg_Count
(0);
12946 Check_Valid_Configuration_Pragma
;
12948 -- Now set appropriate Ada mode
12950 Ada_Version
:= Ada_2020
;
12951 Ada_Version_Explicit
:= Ada_2020
;
12952 Ada_Version_Pragma
:= N
;
12954 ----------------------
12955 -- All_Calls_Remote --
12956 ----------------------
12958 -- pragma All_Calls_Remote [(library_package_NAME)];
12960 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12961 Lib_Entity
: Entity_Id
;
12964 Check_Ada_83_Warning
;
12965 Check_Valid_Library_Unit_Pragma
;
12967 if Nkind
(N
) = N_Null_Statement
then
12971 Lib_Entity
:= Find_Lib_Unit_Name
;
12973 -- A pragma that applies to a Ghost entity becomes Ghost for the
12974 -- purposes of legality checks and removal of ignored Ghost code.
12976 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12978 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12980 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12981 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12982 Error_Pragma
("pragma% only apply to rci unit");
12984 -- Set flag for entity of the library unit
12987 Set_Has_All_Calls_Remote
(Lib_Entity
);
12990 end All_Calls_Remote
;
12992 ---------------------------
12993 -- Allow_Integer_Address --
12994 ---------------------------
12996 -- pragma Allow_Integer_Address;
12998 when Pragma_Allow_Integer_Address
=>
13000 Check_Valid_Configuration_Pragma
;
13001 Check_Arg_Count
(0);
13003 -- If Address is a private type, then set the flag to allow
13004 -- integer address values. If Address is not private, then this
13005 -- pragma has no purpose, so it is simply ignored. Not clear if
13006 -- there are any such targets now.
13008 if Opt
.Address_Is_Private
then
13009 Opt
.Allow_Integer_Address
:= True;
13017 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13018 -- ARG ::= NAME | EXPRESSION
13020 -- The first two arguments are by convention intended to refer to an
13021 -- external tool and a tool-specific function. These arguments are
13024 when Pragma_Annotate
=> Annotate
: declare
13031 Check_At_Least_N_Arguments
(1);
13033 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
13035 -- Determine whether the last argument is "Entity => local_NAME"
13036 -- and if it is, perform the required semantic checks. Remove the
13037 -- argument from further processing.
13039 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
13040 and then Chars
(Nam_Arg
) = Name_Entity
13042 Check_Arg_Is_Local_Name
(Nam_Arg
);
13043 Arg_Count
:= Arg_Count
- 1;
13045 -- A pragma that applies to a Ghost entity becomes Ghost for
13046 -- the purposes of legality checks and removal of ignored Ghost
13049 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
13050 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
13052 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
13055 -- Not allowed in compiler units (bootstrap issues)
13057 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
13060 -- Continue the processing with last argument removed for now
13062 Check_Arg_Is_Identifier
(Arg1
);
13063 Check_No_Identifiers
;
13066 -- The second parameter is optional, it is never analyzed
13071 -- Otherwise there is a second parameter
13074 -- The second parameter must be an identifier
13076 Check_Arg_Is_Identifier
(Arg2
);
13078 -- Process the remaining parameters (if any)
13080 Arg
:= Next
(Arg2
);
13081 while Present
(Arg
) loop
13082 Expr
:= Get_Pragma_Arg
(Arg
);
13085 if Is_Entity_Name
(Expr
) then
13088 -- For string literals, we assume Standard_String as the
13089 -- type, unless the string contains wide or wide_wide
13092 elsif Nkind
(Expr
) = N_String_Literal
then
13093 if Has_Wide_Wide_Character
(Expr
) then
13094 Resolve
(Expr
, Standard_Wide_Wide_String
);
13095 elsif Has_Wide_Character
(Expr
) then
13096 Resolve
(Expr
, Standard_Wide_String
);
13098 Resolve
(Expr
, Standard_String
);
13101 elsif Is_Overloaded
(Expr
) then
13102 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13113 -------------------------------------------------
13114 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13115 -------------------------------------------------
13118 -- ( [Check => ] Boolean_EXPRESSION
13119 -- [, [Message =>] Static_String_EXPRESSION]);
13121 -- pragma Assert_And_Cut
13122 -- ( [Check => ] Boolean_EXPRESSION
13123 -- [, [Message =>] Static_String_EXPRESSION]);
13126 -- ( [Check => ] Boolean_EXPRESSION
13127 -- [, [Message =>] Static_String_EXPRESSION]);
13129 -- pragma Loop_Invariant
13130 -- ( [Check => ] Boolean_EXPRESSION
13131 -- [, [Message =>] Static_String_EXPRESSION]);
13134 | Pragma_Assert_And_Cut
13136 | Pragma_Loop_Invariant
13139 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13140 -- Determine whether expression Expr contains a Loop_Entry
13141 -- attribute reference.
13143 -------------------------
13144 -- Contains_Loop_Entry --
13145 -------------------------
13147 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13148 Has_Loop_Entry
: Boolean := False;
13150 function Process
(N
: Node_Id
) return Traverse_Result
;
13151 -- Process function for traversal to look for Loop_Entry
13157 function Process
(N
: Node_Id
) return Traverse_Result
is
13159 if Nkind
(N
) = N_Attribute_Reference
13160 and then Attribute_Name
(N
) = Name_Loop_Entry
13162 Has_Loop_Entry
:= True;
13169 procedure Traverse
is new Traverse_Proc
(Process
);
13171 -- Start of processing for Contains_Loop_Entry
13175 return Has_Loop_Entry
;
13176 end Contains_Loop_Entry
;
13181 New_Args
: List_Id
;
13183 -- Start of processing for Assert
13186 -- Assert is an Ada 2005 RM-defined pragma
13188 if Prag_Id
= Pragma_Assert
then
13191 -- The remaining ones are GNAT pragmas
13197 Check_At_Least_N_Arguments
(1);
13198 Check_At_Most_N_Arguments
(2);
13199 Check_Arg_Order
((Name_Check
, Name_Message
));
13200 Check_Optional_Identifier
(Arg1
, Name_Check
);
13201 Expr
:= Get_Pragma_Arg
(Arg1
);
13203 -- Special processing for Loop_Invariant, Loop_Variant or for
13204 -- other cases where a Loop_Entry attribute is present. If the
13205 -- assertion pragma contains attribute Loop_Entry, ensure that
13206 -- the related pragma is within a loop.
13208 if Prag_Id
= Pragma_Loop_Invariant
13209 or else Prag_Id
= Pragma_Loop_Variant
13210 or else Contains_Loop_Entry
(Expr
)
13212 Check_Loop_Pragma_Placement
;
13214 -- Perform preanalysis to deal with embedded Loop_Entry
13217 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13220 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13221 -- a corresponding Check pragma:
13223 -- pragma Check (name, condition [, msg]);
13225 -- Where name is the identifier matching the pragma name. So
13226 -- rewrite pragma in this manner, transfer the message argument
13227 -- if present, and analyze the result
13229 -- Note: When dealing with a semantically analyzed tree, the
13230 -- information that a Check node N corresponds to a source Assert,
13231 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13232 -- pragma kind of Original_Node(N).
13234 New_Args
:= New_List
(
13235 Make_Pragma_Argument_Association
(Loc
,
13236 Expression
=> Make_Identifier
(Loc
, Pname
)),
13237 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13238 Expression
=> Expr
));
13240 if Arg_Count
> 1 then
13241 Check_Optional_Identifier
(Arg2
, Name_Message
);
13243 -- Provide semantic annnotations for optional argument, for
13244 -- ASIS use, before rewriting.
13246 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13247 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13250 -- Rewrite as Check pragma
13254 Chars
=> Name_Check
,
13255 Pragma_Argument_Associations
=> New_Args
));
13260 ----------------------
13261 -- Assertion_Policy --
13262 ----------------------
13264 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13266 -- The following form is Ada 2012 only, but we allow it in all modes
13268 -- Pragma Assertion_Policy (
13269 -- ASSERTION_KIND => POLICY_IDENTIFIER
13270 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13272 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13274 -- RM_ASSERTION_KIND ::= Assert |
13275 -- Static_Predicate |
13276 -- Dynamic_Predicate |
13281 -- Type_Invariant |
13282 -- Type_Invariant'Class
13284 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13286 -- Contract_Cases |
13288 -- Default_Initial_Condition |
13290 -- Initial_Condition |
13291 -- Loop_Invariant |
13297 -- Statement_Assertions
13299 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13300 -- ID_ASSERTION_KIND list contains implementation-defined additions
13301 -- recognized by GNAT. The effect is to control the behavior of
13302 -- identically named aspects and pragmas, depending on the specified
13303 -- policy identifier:
13305 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13307 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13308 -- implementation-defined addition that results in totally ignoring
13309 -- the corresponding assertion. If Disable is specified, then the
13310 -- argument of the assertion is not even analyzed. This is useful
13311 -- when the aspect/pragma argument references entities in a with'ed
13312 -- package that is replaced by a dummy package in the final build.
13314 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13315 -- and Type_Invariant'Class were recognized by the parser and
13316 -- transformed into references to the special internal identifiers
13317 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13318 -- processing is required here.
13320 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13321 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13322 -- Converts the assertion policy 'Suppressible' to either Check or
13323 -- Ignore based on whether checks are suppressed via -gnatp.
13325 --------------------------
13326 -- Resolve_Suppressible --
13327 --------------------------
13329 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13330 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13334 -- Transform policy argument Suppressible into either Ignore or
13335 -- Check depending on whether checks are enabled or suppressed.
13337 if Chars
(Arg
) = Name_Suppressible
then
13338 if Suppress_Checks
then
13339 Nam
:= Name_Ignore
;
13344 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13346 end Resolve_Suppressible
;
13358 -- This can always appear as a configuration pragma
13360 if Is_Configuration_Pragma
then
13363 -- It can also appear in a declarative part or package spec in Ada
13364 -- 2012 mode. We allow this in other modes, but in that case we
13365 -- consider that we have an Ada 2012 pragma on our hands.
13368 Check_Is_In_Decl_Part_Or_Package_Spec
;
13372 -- One argument case with no identifier (first form above)
13375 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13376 or else Chars
(Arg1
) = No_Name
)
13378 Check_Arg_Is_One_Of
(Arg1
,
13379 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13381 Resolve_Suppressible
(Arg1
);
13383 -- Treat one argument Assertion_Policy as equivalent to:
13385 -- pragma Check_Policy (Assertion, policy)
13387 -- So rewrite pragma in that manner and link on to the chain
13388 -- of Check_Policy pragmas, marking the pragma as analyzed.
13390 Policy
:= Get_Pragma_Arg
(Arg1
);
13394 Chars
=> Name_Check_Policy
,
13395 Pragma_Argument_Associations
=> New_List
(
13396 Make_Pragma_Argument_Association
(Loc
,
13397 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13399 Make_Pragma_Argument_Association
(Loc
,
13401 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13404 -- Here if we have two or more arguments
13407 Check_At_Least_N_Arguments
(1);
13410 -- Loop through arguments
13413 while Present
(Arg
) loop
13414 LocP
:= Sloc
(Arg
);
13416 -- Kind must be specified
13418 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13419 or else Chars
(Arg
) = No_Name
13422 ("missing assertion kind for pragma%", Arg
);
13425 -- Check Kind and Policy have allowed forms
13427 Kind
:= Chars
(Arg
);
13428 Policy
:= Get_Pragma_Arg
(Arg
);
13430 if not Is_Valid_Assertion_Kind
(Kind
) then
13432 ("invalid assertion kind for pragma%", Arg
);
13435 Check_Arg_Is_One_Of
(Arg
,
13436 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13438 Resolve_Suppressible
(Arg
);
13440 if Kind
= Name_Ghost
then
13442 -- The Ghost policy must be either Check or Ignore
13443 -- (SPARK RM 6.9(6)).
13445 if not Nam_In
(Chars
(Policy
), Name_Check
,
13449 ("argument of pragma % Ghost must be Check or "
13450 & "Ignore", Policy
);
13453 -- Pragma Assertion_Policy specifying a Ghost policy
13454 -- cannot occur within a Ghost subprogram or package
13455 -- (SPARK RM 6.9(14)).
13457 if Ghost_Mode
> None
then
13459 ("pragma % cannot appear within ghost subprogram or "
13464 -- Rewrite the Assertion_Policy pragma as a series of
13465 -- Check_Policy pragmas of the form:
13467 -- Check_Policy (Kind, Policy);
13469 -- Note: the insertion of the pragmas cannot be done with
13470 -- Insert_Action because in the configuration case, there
13471 -- are no scopes on the scope stack and the mechanism will
13474 Insert_Before_And_Analyze
(N
,
13476 Chars
=> Name_Check_Policy
,
13477 Pragma_Argument_Associations
=> New_List
(
13478 Make_Pragma_Argument_Association
(LocP
,
13479 Expression
=> Make_Identifier
(LocP
, Kind
)),
13480 Make_Pragma_Argument_Association
(LocP
,
13481 Expression
=> Policy
))));
13486 -- Rewrite the Assertion_Policy pragma as null since we have
13487 -- now inserted all the equivalent Check pragmas.
13489 Rewrite
(N
, Make_Null_Statement
(Loc
));
13492 end Assertion_Policy
;
13494 ------------------------------
13495 -- Assume_No_Invalid_Values --
13496 ------------------------------
13498 -- pragma Assume_No_Invalid_Values (On | Off);
13500 when Pragma_Assume_No_Invalid_Values
=>
13502 Check_Valid_Configuration_Pragma
;
13503 Check_Arg_Count
(1);
13504 Check_No_Identifiers
;
13505 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13507 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13508 Assume_No_Invalid_Values
:= True;
13510 Assume_No_Invalid_Values
:= False;
13513 --------------------------
13514 -- Attribute_Definition --
13515 --------------------------
13517 -- pragma Attribute_Definition
13518 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13519 -- [Entity =>] LOCAL_NAME,
13520 -- [Expression =>] EXPRESSION | NAME);
13522 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13523 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13528 Check_Arg_Count
(3);
13529 Check_Optional_Identifier
(Arg1
, "attribute");
13530 Check_Optional_Identifier
(Arg2
, "entity");
13531 Check_Optional_Identifier
(Arg3
, "expression");
13533 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13534 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13538 Check_Arg_Is_Local_Name
(Arg2
);
13540 -- If the attribute is not recognized, then issue a warning (not
13541 -- an error), and ignore the pragma.
13543 Aname
:= Chars
(Attribute_Designator
);
13545 if not Is_Attribute_Name
(Aname
) then
13546 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13550 -- Otherwise, rewrite the pragma as an attribute definition clause
13553 Make_Attribute_Definition_Clause
(Loc
,
13554 Name
=> Get_Pragma_Arg
(Arg2
),
13556 Expression
=> Get_Pragma_Arg
(Arg3
)));
13558 end Attribute_Definition
;
13560 ------------------------------------------------------------------
13561 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13562 ------------------------------------------------------------------
13564 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
13565 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
13566 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13567 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13569 when Pragma_Async_Readers
13570 | Pragma_Async_Writers
13571 | Pragma_Effective_Reads
13572 | Pragma_Effective_Writes
13574 Async_Effective
: declare
13575 Obj_Decl
: Node_Id
;
13576 Obj_Id
: Entity_Id
;
13580 Check_No_Identifiers
;
13581 Check_At_Most_N_Arguments
(1);
13583 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13585 -- Object declaration
13587 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
13592 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13594 -- Perform minimal verification to ensure that the argument is at
13595 -- least a variable. Subsequent finer grained checks will be done
13596 -- at the end of the declarative region the contains the pragma.
13598 if Ekind
(Obj_Id
) = E_Variable
then
13600 -- A pragma that applies to a Ghost entity becomes Ghost for
13601 -- the purposes of legality checks and removal of ignored Ghost
13604 Mark_Ghost_Pragma
(N
, Obj_Id
);
13606 -- Chain the pragma on the contract for further processing by
13607 -- Analyze_External_Property_In_Decl_Part.
13609 Add_Contract_Item
(N
, Obj_Id
);
13611 -- Analyze the Boolean expression (if any)
13613 if Present
(Arg1
) then
13614 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13617 -- Otherwise the external property applies to a constant
13620 Error_Pragma
("pragma % must apply to a volatile object");
13622 end Async_Effective
;
13628 -- pragma Asynchronous (LOCAL_NAME);
13630 when Pragma_Asynchronous
=> Asynchronous
: declare
13633 Formal
: Entity_Id
;
13638 procedure Process_Async_Pragma
;
13639 -- Common processing for procedure and access-to-procedure case
13641 --------------------------
13642 -- Process_Async_Pragma --
13643 --------------------------
13645 procedure Process_Async_Pragma
is
13648 Set_Is_Asynchronous
(Nm
);
13652 -- The formals should be of mode IN (RM E.4.1(6))
13655 while Present
(S
) loop
13656 Formal
:= Defining_Identifier
(S
);
13658 if Nkind
(Formal
) = N_Defining_Identifier
13659 and then Ekind
(Formal
) /= E_In_Parameter
13662 ("pragma% procedure can only have IN parameter",
13669 Set_Is_Asynchronous
(Nm
);
13670 end Process_Async_Pragma
;
13672 -- Start of processing for pragma Asynchronous
13675 Check_Ada_83_Warning
;
13676 Check_No_Identifiers
;
13677 Check_Arg_Count
(1);
13678 Check_Arg_Is_Local_Name
(Arg1
);
13680 if Debug_Flag_U
then
13684 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13685 Analyze
(Get_Pragma_Arg
(Arg1
));
13686 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
13688 -- A pragma that applies to a Ghost entity becomes Ghost for the
13689 -- purposes of legality checks and removal of ignored Ghost code.
13691 Mark_Ghost_Pragma
(N
, Nm
);
13693 if not Is_Remote_Call_Interface
(C_Ent
)
13694 and then not Is_Remote_Types
(C_Ent
)
13696 -- This pragma should only appear in an RCI or Remote Types
13697 -- unit (RM E.4.1(4)).
13700 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13703 if Ekind
(Nm
) = E_Procedure
13704 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13706 if not Is_Remote_Call_Interface
(Nm
) then
13708 ("pragma% cannot be applied on non-remote procedure",
13712 L
:= Parameter_Specifications
(Parent
(Nm
));
13713 Process_Async_Pragma
;
13716 elsif Ekind
(Nm
) = E_Function
then
13718 ("pragma% cannot be applied to function", Arg1
);
13720 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13721 if Is_Record_Type
(Nm
) then
13723 -- A record type that is the Equivalent_Type for a remote
13724 -- access-to-subprogram type.
13726 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13729 -- A non-expanded RAS type (distribution is not enabled)
13731 Decl
:= Declaration_Node
(Nm
);
13734 if Nkind
(Decl
) = N_Full_Type_Declaration
13735 and then Nkind
(Type_Definition
(Decl
)) =
13736 N_Access_Procedure_Definition
13738 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13739 Process_Async_Pragma
;
13741 if Is_Asynchronous
(Nm
)
13742 and then Expander_Active
13743 and then Get_PCS_Name
/= Name_No_DSA
13745 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13750 ("pragma% cannot reference access-to-function type",
13754 -- Only other possibility is Access-to-class-wide type
13756 elsif Is_Access_Type
(Nm
)
13757 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13759 Check_First_Subtype
(Arg1
);
13760 Set_Is_Asynchronous
(Nm
);
13761 if Expander_Active
then
13762 RACW_Type_Is_Asynchronous
(Nm
);
13766 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13774 -- pragma Atomic (LOCAL_NAME);
13776 when Pragma_Atomic
=>
13777 Process_Atomic_Independent_Shared_Volatile
;
13779 -----------------------
13780 -- Atomic_Components --
13781 -----------------------
13783 -- pragma Atomic_Components (array_LOCAL_NAME);
13785 -- This processing is shared by Volatile_Components
13787 when Pragma_Atomic_Components
13788 | Pragma_Volatile_Components
13790 Atomic_Components
: declare
13797 Check_Ada_83_Warning
;
13798 Check_No_Identifiers
;
13799 Check_Arg_Count
(1);
13800 Check_Arg_Is_Local_Name
(Arg1
);
13801 E_Id
:= Get_Pragma_Arg
(Arg1
);
13803 if Etype
(E_Id
) = Any_Type
then
13807 E
:= Entity
(E_Id
);
13809 -- A pragma that applies to a Ghost entity becomes Ghost for the
13810 -- purposes of legality checks and removal of ignored Ghost code.
13812 Mark_Ghost_Pragma
(N
, E
);
13813 Check_Duplicate_Pragma
(E
);
13815 if Rep_Item_Too_Early
(E
, N
)
13817 Rep_Item_Too_Late
(E
, N
)
13822 D
:= Declaration_Node
(E
);
13825 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13827 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13828 and then Nkind
(D
) = N_Object_Declaration
13829 and then Nkind
(Object_Definition
(D
)) =
13830 N_Constrained_Array_Definition
)
13832 -- The flag is set on the object, or on the base type
13834 if Nkind
(D
) /= N_Object_Declaration
then
13835 E
:= Base_Type
(E
);
13838 -- Atomic implies both Independent and Volatile
13840 if Prag_Id
= Pragma_Atomic_Components
then
13841 Set_Has_Atomic_Components
(E
);
13842 Set_Has_Independent_Components
(E
);
13845 Set_Has_Volatile_Components
(E
);
13848 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13850 end Atomic_Components
;
13852 --------------------
13853 -- Attach_Handler --
13854 --------------------
13856 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13858 when Pragma_Attach_Handler
=>
13859 Check_Ada_83_Warning
;
13860 Check_No_Identifiers
;
13861 Check_Arg_Count
(2);
13863 if No_Run_Time_Mode
then
13864 Error_Msg_CRT
("Attach_Handler pragma", N
);
13866 Check_Interrupt_Or_Attach_Handler
;
13868 -- The expression that designates the attribute may depend on a
13869 -- discriminant, and is therefore a per-object expression, to
13870 -- be expanded in the init proc. If expansion is enabled, then
13871 -- perform semantic checks on a copy only.
13876 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13879 -- In Relaxed_RM_Semantics mode, we allow any static
13880 -- integer value, for compatibility with other compilers.
13882 if Relaxed_RM_Semantics
13883 and then Nkind
(Parg2
) = N_Integer_Literal
13885 Typ
:= Standard_Integer
;
13887 Typ
:= RTE
(RE_Interrupt_ID
);
13890 if Expander_Active
then
13891 Temp
:= New_Copy_Tree
(Parg2
);
13892 Set_Parent
(Temp
, N
);
13893 Preanalyze_And_Resolve
(Temp
, Typ
);
13896 Resolve
(Parg2
, Typ
);
13900 Process_Interrupt_Or_Attach_Handler
;
13903 --------------------
13904 -- C_Pass_By_Copy --
13905 --------------------
13907 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13909 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13915 Check_Valid_Configuration_Pragma
;
13916 Check_Arg_Count
(1);
13917 Check_Optional_Identifier
(Arg1
, "max_size");
13919 Arg
:= Get_Pragma_Arg
(Arg1
);
13920 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13922 Val
:= Expr_Value
(Arg
);
13926 ("maximum size for pragma% must be positive", Arg1
);
13928 elsif UI_Is_In_Int_Range
(Val
) then
13929 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13931 -- If a giant value is given, Int'Last will do well enough.
13932 -- If sometime someone complains that a record larger than
13933 -- two gigabytes is not copied, we will worry about it then.
13936 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13938 end C_Pass_By_Copy
;
13944 -- pragma Check ([Name =>] CHECK_KIND,
13945 -- [Check =>] Boolean_EXPRESSION
13946 -- [,[Message =>] String_EXPRESSION]);
13948 -- CHECK_KIND ::= IDENTIFIER |
13951 -- Invariant'Class |
13952 -- Type_Invariant'Class
13954 -- The identifiers Assertions and Statement_Assertions are not
13955 -- allowed, since they have special meaning for Check_Policy.
13957 -- WARNING: The code below manages Ghost regions. Return statements
13958 -- must be replaced by gotos which jump to the end of the code and
13959 -- restore the Ghost mode.
13961 when Pragma_Check
=> Check
: declare
13962 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13963 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13964 -- Save the Ghost-related attributes to restore on exit
13970 pragma Warnings
(Off
, Str
);
13973 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13974 -- the mode now to ensure that any nodes generated during analysis
13975 -- and expansion are marked as Ghost.
13977 Set_Ghost_Mode
(N
);
13980 Check_At_Least_N_Arguments
(2);
13981 Check_At_Most_N_Arguments
(3);
13982 Check_Optional_Identifier
(Arg1
, Name_Name
);
13983 Check_Optional_Identifier
(Arg2
, Name_Check
);
13985 if Arg_Count
= 3 then
13986 Check_Optional_Identifier
(Arg3
, Name_Message
);
13987 Str
:= Get_Pragma_Arg
(Arg3
);
13990 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13991 Check_Arg_Is_Identifier
(Arg1
);
13992 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13994 -- Check forbidden name Assertions or Statement_Assertions
13997 when Name_Assertions
=>
13999 ("""Assertions"" is not allowed as a check kind for "
14000 & "pragma%", Arg1
);
14002 when Name_Statement_Assertions
=>
14004 ("""Statement_Assertions"" is not allowed as a check kind "
14005 & "for pragma%", Arg1
);
14011 -- Check applicable policy. We skip this if Checked/Ignored status
14012 -- is already set (e.g. in the case of a pragma from an aspect).
14014 if Is_Checked
(N
) or else Is_Ignored
(N
) then
14017 -- For a non-source pragma that is a rewriting of another pragma,
14018 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14020 elsif Is_Rewrite_Substitution
(N
)
14021 and then Nkind
(Original_Node
(N
)) = N_Pragma
14023 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
14024 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
14026 -- Otherwise query the applicable policy at this point
14029 case Check_Kind
(Cname
) is
14030 when Name_Ignore
=>
14031 Set_Is_Ignored
(N
, True);
14032 Set_Is_Checked
(N
, False);
14035 Set_Is_Ignored
(N
, False);
14036 Set_Is_Checked
(N
, True);
14038 -- For disable, rewrite pragma as null statement and skip
14039 -- rest of the analysis of the pragma.
14041 when Name_Disable
=>
14042 Rewrite
(N
, Make_Null_Statement
(Loc
));
14046 -- No other possibilities
14049 raise Program_Error
;
14053 -- If check kind was not Disable, then continue pragma analysis
14055 Expr
:= Get_Pragma_Arg
(Arg2
);
14057 -- Deal with SCO generation
14059 if Is_Checked
(N
) and then not Split_PPC
(N
) then
14060 Set_SCO_Pragma_Enabled
(Loc
);
14063 -- Deal with analyzing the string argument. If checks are not
14064 -- on we don't want any expansion (since such expansion would
14065 -- not get properly deleted) but we do want to analyze (to get
14066 -- proper references). The Preanalyze_And_Resolve routine does
14067 -- just what we want. Ditto if pragma is active, because it will
14068 -- be rewritten as an if-statement whose analysis will complete
14069 -- analysis and expansion of the string message. This makes a
14070 -- difference in the unusual case where the expression for the
14071 -- string may have a side effect, such as raising an exception.
14072 -- This is mandated by RM 11.4.2, which specifies that the string
14073 -- expression is only evaluated if the check fails and
14074 -- Assertion_Error is to be raised.
14076 if Arg_Count
= 3 then
14077 Preanalyze_And_Resolve
(Str
, Standard_String
);
14080 -- Now you might think we could just do the same with the Boolean
14081 -- expression if checks are off (and expansion is on) and then
14082 -- rewrite the check as a null statement. This would work but we
14083 -- would lose the useful warnings about an assertion being bound
14084 -- to fail even if assertions are turned off.
14086 -- So instead we wrap the boolean expression in an if statement
14087 -- that looks like:
14089 -- if False and then condition then
14093 -- The reason we do this rewriting during semantic analysis rather
14094 -- than as part of normal expansion is that we cannot analyze and
14095 -- expand the code for the boolean expression directly, or it may
14096 -- cause insertion of actions that would escape the attempt to
14097 -- suppress the check code.
14099 -- Note that the Sloc for the if statement corresponds to the
14100 -- argument condition, not the pragma itself. The reason for
14101 -- this is that we may generate a warning if the condition is
14102 -- False at compile time, and we do not want to delete this
14103 -- warning when we delete the if statement.
14105 if Expander_Active
and Is_Ignored
(N
) then
14106 Eloc
:= Sloc
(Expr
);
14109 Make_If_Statement
(Eloc
,
14111 Make_And_Then
(Eloc
,
14112 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14113 Right_Opnd
=> Expr
),
14114 Then_Statements
=> New_List
(
14115 Make_Null_Statement
(Eloc
))));
14117 -- Now go ahead and analyze the if statement
14119 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14121 -- One rather special treatment. If we are now in Eliminated
14122 -- overflow mode, then suppress overflow checking since we do
14123 -- not want to drag in the bignum stuff if we are in Ignore
14124 -- mode anyway. This is particularly important if we are using
14125 -- a configurable run time that does not support bignum ops.
14127 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14129 Svo
: constant Boolean :=
14130 Scope_Suppress
.Suppress
(Overflow_Check
);
14132 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14133 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14135 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14136 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14139 -- Not that special case
14145 -- All done with this check
14147 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14149 -- Check is active or expansion not active. In these cases we can
14150 -- just go ahead and analyze the boolean with no worries.
14153 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14154 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14155 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14158 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14161 --------------------------
14162 -- Check_Float_Overflow --
14163 --------------------------
14165 -- pragma Check_Float_Overflow;
14167 when Pragma_Check_Float_Overflow
=>
14169 Check_Valid_Configuration_Pragma
;
14170 Check_Arg_Count
(0);
14171 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14177 -- pragma Check_Name (check_IDENTIFIER);
14179 when Pragma_Check_Name
=>
14181 Check_No_Identifiers
;
14182 Check_Valid_Configuration_Pragma
;
14183 Check_Arg_Count
(1);
14184 Check_Arg_Is_Identifier
(Arg1
);
14187 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14190 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14191 if Check_Names
.Table
(J
) = Nam
then
14196 Check_Names
.Append
(Nam
);
14203 -- This is the old style syntax, which is still allowed in all modes:
14205 -- pragma Check_Policy ([Name =>] CHECK_KIND
14206 -- [Policy =>] POLICY_IDENTIFIER);
14208 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14210 -- CHECK_KIND ::= IDENTIFIER |
14213 -- Type_Invariant'Class |
14216 -- This is the new style syntax, compatible with Assertion_Policy
14217 -- and also allowed in all modes.
14219 -- Pragma Check_Policy (
14220 -- CHECK_KIND => POLICY_IDENTIFIER
14221 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14223 -- Note: the identifiers Name and Policy are not allowed as
14224 -- Check_Kind values. This avoids ambiguities between the old and
14225 -- new form syntax.
14227 when Pragma_Check_Policy
=> Check_Policy
: declare
14232 Check_At_Least_N_Arguments
(1);
14234 -- A Check_Policy pragma can appear either as a configuration
14235 -- pragma, or in a declarative part or a package spec (see RM
14236 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14237 -- followed for Check_Policy).
14239 if not Is_Configuration_Pragma
then
14240 Check_Is_In_Decl_Part_Or_Package_Spec
;
14243 -- Figure out if we have the old or new syntax. We have the
14244 -- old syntax if the first argument has no identifier, or the
14245 -- identifier is Name.
14247 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14248 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
14252 Check_Arg_Count
(2);
14253 Check_Optional_Identifier
(Arg1
, Name_Name
);
14254 Kind
:= Get_Pragma_Arg
(Arg1
);
14255 Rewrite_Assertion_Kind
(Kind
,
14256 From_Policy
=> Comes_From_Source
(N
));
14257 Check_Arg_Is_Identifier
(Arg1
);
14259 -- Check forbidden check kind
14261 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
14262 Error_Msg_Name_2
:= Chars
(Kind
);
14264 ("pragma% does not allow% as check name", Arg1
);
14269 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14270 Check_Arg_Is_One_Of
14272 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14274 -- And chain pragma on the Check_Policy_List for search
14276 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14277 Opt
.Check_Policy_List
:= N
;
14279 -- For the new syntax, what we do is to convert each argument to
14280 -- an old syntax equivalent. We do that because we want to chain
14281 -- old style Check_Policy pragmas for the search (we don't want
14282 -- to have to deal with multiple arguments in the search).
14293 while Present
(Arg
) loop
14294 LocP
:= Sloc
(Arg
);
14295 Argx
:= Get_Pragma_Arg
(Arg
);
14297 -- Kind must be specified
14299 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14300 or else Chars
(Arg
) = No_Name
14303 ("missing assertion kind for pragma%", Arg
);
14306 -- Construct equivalent old form syntax Check_Policy
14307 -- pragma and insert it to get remaining checks.
14311 Chars
=> Name_Check_Policy
,
14312 Pragma_Argument_Associations
=> New_List
(
14313 Make_Pragma_Argument_Association
(LocP
,
14315 Make_Identifier
(LocP
, Chars
(Arg
))),
14316 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14317 Expression
=> Argx
)));
14321 -- For a configuration pragma, insert old form in
14322 -- the corresponding file.
14324 if Is_Configuration_Pragma
then
14325 Insert_After
(N
, New_P
);
14329 Insert_Action
(N
, New_P
);
14333 -- Rewrite original Check_Policy pragma to null, since we
14334 -- have converted it into a series of old syntax pragmas.
14336 Rewrite
(N
, Make_Null_Statement
(Loc
));
14346 -- pragma Comment (static_string_EXPRESSION)
14348 -- Processing for pragma Comment shares the circuitry for pragma
14349 -- Ident. The only differences are that Ident enforces a limit of 31
14350 -- characters on its argument, and also enforces limitations on
14351 -- placement for DEC compatibility. Pragma Comment shares neither of
14352 -- these restrictions.
14354 -------------------
14355 -- Common_Object --
14356 -------------------
14358 -- pragma Common_Object (
14359 -- [Internal =>] LOCAL_NAME
14360 -- [, [External =>] EXTERNAL_SYMBOL]
14361 -- [, [Size =>] EXTERNAL_SYMBOL]);
14363 -- Processing for this pragma is shared with Psect_Object
14365 ------------------------
14366 -- Compile_Time_Error --
14367 ------------------------
14369 -- pragma Compile_Time_Error
14370 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14372 when Pragma_Compile_Time_Error
=>
14374 Process_Compile_Time_Warning_Or_Error
;
14376 --------------------------
14377 -- Compile_Time_Warning --
14378 --------------------------
14380 -- pragma Compile_Time_Warning
14381 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14383 when Pragma_Compile_Time_Warning
=>
14385 Process_Compile_Time_Warning_Or_Error
;
14387 ---------------------------
14388 -- Compiler_Unit_Warning --
14389 ---------------------------
14391 -- pragma Compiler_Unit_Warning;
14395 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14396 -- errors not warnings. This means that we had introduced a big extra
14397 -- inertia to compiler changes, since even if we implemented a new
14398 -- feature, and even if all versions to be used for bootstrapping
14399 -- implemented this new feature, we could not use it, since old
14400 -- compilers would give errors for using this feature in units
14401 -- having Compiler_Unit pragmas.
14403 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14404 -- problem. We no longer have any units mentioning Compiler_Unit,
14405 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14406 -- and thus generates a warning which can be ignored. So that deals
14407 -- with the problem of old compilers not implementing the newer form
14410 -- Newer compilers recognize the new pragma, but generate warning
14411 -- messages instead of errors, which again can be ignored in the
14412 -- case of an old compiler which implements a wanted new feature
14413 -- but at the time felt like warning about it for older compilers.
14415 -- We retain Compiler_Unit so that new compilers can be used to build
14416 -- older run-times that use this pragma. That's an unusual case, but
14417 -- it's easy enough to handle, so why not?
14419 when Pragma_Compiler_Unit
14420 | Pragma_Compiler_Unit_Warning
14423 Check_Arg_Count
(0);
14425 -- Only recognized in main unit
14427 if Current_Sem_Unit
= Main_Unit
then
14428 Compiler_Unit
:= True;
14431 -----------------------------
14432 -- Complete_Representation --
14433 -----------------------------
14435 -- pragma Complete_Representation;
14437 when Pragma_Complete_Representation
=>
14439 Check_Arg_Count
(0);
14441 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14443 ("pragma & must appear within record representation clause");
14446 ----------------------------
14447 -- Complex_Representation --
14448 ----------------------------
14450 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14452 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14459 Check_Arg_Count
(1);
14460 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14461 Check_Arg_Is_Local_Name
(Arg1
);
14462 E_Id
:= Get_Pragma_Arg
(Arg1
);
14464 if Etype
(E_Id
) = Any_Type
then
14468 E
:= Entity
(E_Id
);
14470 if not Is_Record_Type
(E
) then
14472 ("argument for pragma% must be record type", Arg1
);
14475 Ent
:= First_Entity
(E
);
14478 or else No
(Next_Entity
(Ent
))
14479 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14480 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14481 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14484 ("record for pragma% must have two fields of the same "
14485 & "floating-point type", Arg1
);
14488 Set_Has_Complex_Representation
(Base_Type
(E
));
14490 -- We need to treat the type has having a non-standard
14491 -- representation, for back-end purposes, even though in
14492 -- general a complex will have the default representation
14493 -- of a record with two real components.
14495 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14497 end Complex_Representation
;
14499 -------------------------
14500 -- Component_Alignment --
14501 -------------------------
14503 -- pragma Component_Alignment (
14504 -- [Form =>] ALIGNMENT_CHOICE
14505 -- [, [Name =>] type_LOCAL_NAME]);
14507 -- ALIGNMENT_CHOICE ::=
14509 -- | Component_Size_4
14513 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14514 Args
: Args_List
(1 .. 2);
14515 Names
: constant Name_List
(1 .. 2) := (
14519 Form
: Node_Id
renames Args
(1);
14520 Name
: Node_Id
renames Args
(2);
14522 Atype
: Component_Alignment_Kind
;
14527 Gather_Associations
(Names
, Args
);
14530 Error_Pragma
("missing Form argument for pragma%");
14533 Check_Arg_Is_Identifier
(Form
);
14535 -- Get proper alignment, note that Default = Component_Size on all
14536 -- machines we have so far, and we want to set this value rather
14537 -- than the default value to indicate that it has been explicitly
14538 -- set (and thus will not get overridden by the default component
14539 -- alignment for the current scope)
14541 if Chars
(Form
) = Name_Component_Size
then
14542 Atype
:= Calign_Component_Size
;
14544 elsif Chars
(Form
) = Name_Component_Size_4
then
14545 Atype
:= Calign_Component_Size_4
;
14547 elsif Chars
(Form
) = Name_Default
then
14548 Atype
:= Calign_Component_Size
;
14550 elsif Chars
(Form
) = Name_Storage_Unit
then
14551 Atype
:= Calign_Storage_Unit
;
14555 ("invalid Form parameter for pragma%", Form
);
14558 -- The pragma appears in a configuration file
14560 if No
(Parent
(N
)) then
14561 Check_Valid_Configuration_Pragma
;
14563 -- Capture the component alignment in a global variable when
14564 -- the pragma appears in a configuration file. Note that the
14565 -- scope stack is empty at this point and cannot be used to
14566 -- store the alignment value.
14568 Configuration_Component_Alignment
:= Atype
;
14570 -- Case with no name, supplied, affects scope table entry
14572 elsif No
(Name
) then
14574 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14576 -- Case of name supplied
14579 Check_Arg_Is_Local_Name
(Name
);
14581 Typ
:= Entity
(Name
);
14584 or else Rep_Item_Too_Early
(Typ
, N
)
14588 Typ
:= Underlying_Type
(Typ
);
14591 if not Is_Record_Type
(Typ
)
14592 and then not Is_Array_Type
(Typ
)
14595 ("Name parameter of pragma% must identify record or "
14596 & "array type", Name
);
14599 -- An explicit Component_Alignment pragma overrides an
14600 -- implicit pragma Pack, but not an explicit one.
14602 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
14603 Set_Is_Packed
(Base_Type
(Typ
), False);
14604 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
14607 end Component_AlignmentP
;
14609 --------------------------------
14610 -- Constant_After_Elaboration --
14611 --------------------------------
14613 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14615 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
14617 Obj_Decl
: Node_Id
;
14618 Obj_Id
: Entity_Id
;
14622 Check_No_Identifiers
;
14623 Check_At_Most_N_Arguments
(1);
14625 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14627 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
14632 Obj_Id
:= Defining_Entity
(Obj_Decl
);
14634 -- The object declaration must be a library-level variable which
14635 -- is either explicitly initialized or obtains a value during the
14636 -- elaboration of a package body (SPARK RM 3.3.1).
14638 if Ekind
(Obj_Id
) = E_Variable
then
14639 if not Is_Library_Level_Entity
(Obj_Id
) then
14641 ("pragma % must apply to a library level variable");
14645 -- Otherwise the pragma applies to a constant, which is illegal
14648 Error_Pragma
("pragma % must apply to a variable declaration");
14652 -- A pragma that applies to a Ghost entity becomes Ghost for the
14653 -- purposes of legality checks and removal of ignored Ghost code.
14655 Mark_Ghost_Pragma
(N
, Obj_Id
);
14657 -- Chain the pragma on the contract for completeness
14659 Add_Contract_Item
(N
, Obj_Id
);
14661 -- Analyze the Boolean expression (if any)
14663 if Present
(Arg1
) then
14664 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14666 end Constant_After_Elaboration
;
14668 --------------------
14669 -- Contract_Cases --
14670 --------------------
14672 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14674 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14676 -- CASE_GUARD ::= boolean_EXPRESSION | others
14678 -- CONSEQUENCE ::= boolean_EXPRESSION
14680 -- Characteristics:
14682 -- * Analysis - The annotation undergoes initial checks to verify
14683 -- the legal placement and context. Secondary checks preanalyze the
14686 -- Analyze_Contract_Cases_In_Decl_Part
14688 -- * Expansion - The annotation is expanded during the expansion of
14689 -- the related subprogram [body] contract as performed in:
14691 -- Expand_Subprogram_Contract
14693 -- * Template - The annotation utilizes the generic template of the
14694 -- related subprogram [body] when it is:
14696 -- aspect on subprogram declaration
14697 -- aspect on stand-alone subprogram body
14698 -- pragma on stand-alone subprogram body
14700 -- The annotation must prepare its own template when it is:
14702 -- pragma on subprogram declaration
14704 -- * Globals - Capture of global references must occur after full
14707 -- * Instance - The annotation is instantiated automatically when
14708 -- the related generic subprogram [body] is instantiated except for
14709 -- the "pragma on subprogram declaration" case. In that scenario
14710 -- the annotation must instantiate itself.
14712 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14713 Spec_Id
: Entity_Id
;
14714 Subp_Decl
: Node_Id
;
14715 Subp_Spec
: Node_Id
;
14719 Check_No_Identifiers
;
14720 Check_Arg_Count
(1);
14722 -- Ensure the proper placement of the pragma. Contract_Cases must
14723 -- be associated with a subprogram declaration or a body that acts
14727 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14731 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14734 -- Generic subprogram
14736 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14739 -- Body acts as spec
14741 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14742 and then No
(Corresponding_Spec
(Subp_Decl
))
14746 -- Body stub acts as spec
14748 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14749 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14755 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14756 Subp_Spec
:= Specification
(Subp_Decl
);
14758 -- Pragma Contract_Cases is forbidden on null procedures, as
14759 -- this may lead to potential ambiguities in behavior when
14760 -- interface null procedures are involved.
14762 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14763 and then Null_Present
(Subp_Spec
)
14765 Error_Msg_N
(Fix_Error
14766 ("pragma % cannot apply to null procedure"), N
);
14775 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14777 -- A pragma that applies to a Ghost entity becomes Ghost for the
14778 -- purposes of legality checks and removal of ignored Ghost code.
14780 Mark_Ghost_Pragma
(N
, Spec_Id
);
14781 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14783 -- Chain the pragma on the contract for further processing by
14784 -- Analyze_Contract_Cases_In_Decl_Part.
14786 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14788 -- Fully analyze the pragma when it appears inside an entry
14789 -- or subprogram body because it cannot benefit from forward
14792 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14794 N_Subprogram_Body_Stub
)
14796 -- The legality checks of pragma Contract_Cases are affected by
14797 -- the SPARK mode in effect and the volatility of the context.
14798 -- Analyze all pragmas in a specific order.
14800 Analyze_If_Present
(Pragma_SPARK_Mode
);
14801 Analyze_If_Present
(Pragma_Volatile_Function
);
14802 Analyze_Contract_Cases_In_Decl_Part
(N
);
14804 end Contract_Cases
;
14810 -- pragma Controlled (first_subtype_LOCAL_NAME);
14812 when Pragma_Controlled
=> Controlled
: declare
14816 Check_No_Identifiers
;
14817 Check_Arg_Count
(1);
14818 Check_Arg_Is_Local_Name
(Arg1
);
14819 Arg
:= Get_Pragma_Arg
(Arg1
);
14821 if not Is_Entity_Name
(Arg
)
14822 or else not Is_Access_Type
(Entity
(Arg
))
14824 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14826 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14834 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14835 -- [Entity =>] LOCAL_NAME);
14837 when Pragma_Convention
=> Convention
: declare
14840 pragma Warnings
(Off
, C
);
14841 pragma Warnings
(Off
, E
);
14844 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14845 Check_Ada_83_Warning
;
14846 Check_Arg_Count
(2);
14847 Process_Convention
(C
, E
);
14849 -- A pragma that applies to a Ghost entity becomes Ghost for the
14850 -- purposes of legality checks and removal of ignored Ghost code.
14852 Mark_Ghost_Pragma
(N
, E
);
14855 ---------------------------
14856 -- Convention_Identifier --
14857 ---------------------------
14859 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14860 -- [Convention =>] convention_IDENTIFIER);
14862 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14868 Check_Arg_Order
((Name_Name
, Name_Convention
));
14869 Check_Arg_Count
(2);
14870 Check_Optional_Identifier
(Arg1
, Name_Name
);
14871 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14872 Check_Arg_Is_Identifier
(Arg1
);
14873 Check_Arg_Is_Identifier
(Arg2
);
14874 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14875 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14877 if Is_Convention_Name
(Cname
) then
14878 Record_Convention_Identifier
14879 (Idnam
, Get_Convention_Id
(Cname
));
14882 ("second arg for % pragma must be convention", Arg2
);
14884 end Convention_Identifier
;
14890 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14892 when Pragma_CPP_Class
=>
14895 if Warn_On_Obsolescent_Feature
then
14897 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14898 & "effect; replace it by pragma import?j?", N
);
14901 Check_Arg_Count
(1);
14905 Chars
=> Name_Import
,
14906 Pragma_Argument_Associations
=> New_List
(
14907 Make_Pragma_Argument_Association
(Loc
,
14908 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14909 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14912 ---------------------
14913 -- CPP_Constructor --
14914 ---------------------
14916 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14917 -- [, [External_Name =>] static_string_EXPRESSION ]
14918 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14920 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14923 Def_Id
: Entity_Id
;
14924 Tag_Typ
: Entity_Id
;
14928 Check_At_Least_N_Arguments
(1);
14929 Check_At_Most_N_Arguments
(3);
14930 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14931 Check_Arg_Is_Local_Name
(Arg1
);
14933 Id
:= Get_Pragma_Arg
(Arg1
);
14934 Find_Program_Unit_Name
(Id
);
14936 -- If we did not find the name, we are done
14938 if Etype
(Id
) = Any_Type
then
14942 Def_Id
:= Entity
(Id
);
14944 -- Check if already defined as constructor
14946 if Is_Constructor
(Def_Id
) then
14948 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14952 if Ekind
(Def_Id
) = E_Function
14953 and then (Is_CPP_Class
(Etype
(Def_Id
))
14954 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14956 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14958 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14960 ("'C'P'P constructor must be defined in the scope of "
14961 & "its returned type", Arg1
);
14964 if Arg_Count
>= 2 then
14965 Set_Imported
(Def_Id
);
14966 Set_Is_Public
(Def_Id
);
14967 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14970 Set_Has_Completion
(Def_Id
);
14971 Set_Is_Constructor
(Def_Id
);
14972 Set_Convention
(Def_Id
, Convention_CPP
);
14974 -- Imported C++ constructors are not dispatching primitives
14975 -- because in C++ they don't have a dispatch table slot.
14976 -- However, in Ada the constructor has the profile of a
14977 -- function that returns a tagged type and therefore it has
14978 -- been treated as a primitive operation during semantic
14979 -- analysis. We now remove it from the list of primitive
14980 -- operations of the type.
14982 if Is_Tagged_Type
(Etype
(Def_Id
))
14983 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14984 and then Is_Dispatching_Operation
(Def_Id
)
14986 Tag_Typ
:= Etype
(Def_Id
);
14988 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14989 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14993 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14994 Set_Is_Dispatching_Operation
(Def_Id
, False);
14997 -- For backward compatibility, if the constructor returns a
14998 -- class wide type, and we internally change the return type to
14999 -- the corresponding root type.
15001 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
15002 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
15006 ("pragma% requires function returning a 'C'P'P_Class type",
15009 end CPP_Constructor
;
15015 when Pragma_CPP_Virtual
=>
15018 if Warn_On_Obsolescent_Feature
then
15020 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15028 when Pragma_CPP_Vtable
=>
15031 if Warn_On_Obsolescent_Feature
then
15033 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15041 -- pragma CPU (EXPRESSION);
15043 when Pragma_CPU
=> CPU
: declare
15044 P
: constant Node_Id
:= Parent
(N
);
15050 Check_No_Identifiers
;
15051 Check_Arg_Count
(1);
15055 if Nkind
(P
) = N_Subprogram_Body
then
15056 Check_In_Main_Program
;
15058 Arg
:= Get_Pragma_Arg
(Arg1
);
15059 Analyze_And_Resolve
(Arg
, Any_Integer
);
15061 Ent
:= Defining_Unit_Name
(Specification
(P
));
15063 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15064 Ent
:= Defining_Identifier
(Ent
);
15069 if not Is_OK_Static_Expression
(Arg
) then
15070 Flag_Non_Static_Expr
15071 ("main subprogram affinity is not static!", Arg
);
15074 -- If constraint error, then we already signalled an error
15076 elsif Raises_Constraint_Error
(Arg
) then
15079 -- Otherwise check in range
15083 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15084 -- This is the entity System.Multiprocessors.CPU_Range;
15086 Val
: constant Uint
:= Expr_Value
(Arg
);
15089 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15091 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15094 ("main subprogram CPU is out of range", Arg1
);
15100 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15104 elsif Nkind
(P
) = N_Task_Definition
then
15105 Arg
:= Get_Pragma_Arg
(Arg1
);
15106 Ent
:= Defining_Identifier
(Parent
(P
));
15108 -- The expression must be analyzed in the special manner
15109 -- described in "Handling of Default and Per-Object
15110 -- Expressions" in sem.ads.
15112 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15114 -- Anything else is incorrect
15120 -- Check duplicate pragma before we chain the pragma in the Rep
15121 -- Item chain of Ent.
15123 Check_Duplicate_Pragma
(Ent
);
15124 Record_Rep_Item
(Ent
, N
);
15127 --------------------
15128 -- Deadline_Floor --
15129 --------------------
15131 -- pragma Deadline_Floor (time_span_EXPRESSION);
15133 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15134 P
: constant Node_Id
:= Parent
(N
);
15140 Check_No_Identifiers
;
15141 Check_Arg_Count
(1);
15143 Arg
:= Get_Pragma_Arg
(Arg1
);
15145 -- The expression must be analyzed in the special manner described
15146 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15148 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15150 -- Only protected types allowed
15152 if Nkind
(P
) /= N_Protected_Definition
then
15156 Ent
:= Defining_Identifier
(Parent
(P
));
15158 -- Check duplicate pragma before we chain the pragma in the Rep
15159 -- Item chain of Ent.
15161 Check_Duplicate_Pragma
(Ent
);
15162 Record_Rep_Item
(Ent
, N
);
15164 end Deadline_Floor
;
15170 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15172 when Pragma_Debug
=> Debug
: declare
15179 -- The condition for executing the call is that the expander
15180 -- is active and that we are not ignoring this debug pragma.
15185 (Expander_Active
and then not Is_Ignored
(N
)),
15188 if not Is_Ignored
(N
) then
15189 Set_SCO_Pragma_Enabled
(Loc
);
15192 if Arg_Count
= 2 then
15194 Make_And_Then
(Loc
,
15195 Left_Opnd
=> Relocate_Node
(Cond
),
15196 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15197 Call
:= Get_Pragma_Arg
(Arg2
);
15199 Call
:= Get_Pragma_Arg
(Arg1
);
15202 if Nkind_In
(Call
, N_Expanded_Name
,
15205 N_Indexed_Component
,
15206 N_Selected_Component
)
15208 -- If this pragma Debug comes from source, its argument was
15209 -- parsed as a name form (which is syntactically identical).
15210 -- In a generic context a parameterless call will be left as
15211 -- an expanded name (if global) or selected_component if local.
15212 -- Change it to a procedure call statement now.
15214 Change_Name_To_Procedure_Call_Statement
(Call
);
15216 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15218 -- Already in the form of a procedure call statement: nothing
15219 -- to do (could happen in case of an internally generated
15225 -- All other cases: diagnose error
15228 ("argument of pragma ""Debug"" is not procedure call",
15233 -- Rewrite into a conditional with an appropriate condition. We
15234 -- wrap the procedure call in a block so that overhead from e.g.
15235 -- use of the secondary stack does not generate execution overhead
15236 -- for suppressed conditions.
15238 -- Normally the analysis that follows will freeze the subprogram
15239 -- being called. However, if the call is to a null procedure,
15240 -- we want to freeze it before creating the block, because the
15241 -- analysis that follows may be done with expansion disabled, in
15242 -- which case the body will not be generated, leading to spurious
15245 if Nkind
(Call
) = N_Procedure_Call_Statement
15246 and then Is_Entity_Name
(Name
(Call
))
15248 Analyze
(Name
(Call
));
15249 Freeze_Before
(N
, Entity
(Name
(Call
)));
15253 Make_Implicit_If_Statement
(N
,
15255 Then_Statements
=> New_List
(
15256 Make_Block_Statement
(Loc
,
15257 Handled_Statement_Sequence
=>
15258 Make_Handled_Sequence_Of_Statements
(Loc
,
15259 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15262 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15263 -- after analysis of the normally rewritten node, to capture all
15264 -- references to entities, which avoids issuing wrong warnings
15265 -- about unused entities.
15267 if GNATprove_Mode
then
15268 Rewrite
(N
, Make_Null_Statement
(Loc
));
15276 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15278 when Pragma_Debug_Policy
=>
15280 Check_Arg_Count
(1);
15281 Check_No_Identifiers
;
15282 Check_Arg_Is_Identifier
(Arg1
);
15284 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15285 -- rewrite it that way, and let the rest of the checking come
15286 -- from analyzing the rewritten pragma.
15290 Chars
=> Name_Check_Policy
,
15291 Pragma_Argument_Associations
=> New_List
(
15292 Make_Pragma_Argument_Association
(Loc
,
15293 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15295 Make_Pragma_Argument_Association
(Loc
,
15296 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15299 -------------------------------
15300 -- Default_Initial_Condition --
15301 -------------------------------
15303 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15305 when Pragma_Default_Initial_Condition
=> DIC
: declare
15312 Check_No_Identifiers
;
15313 Check_At_Most_N_Arguments
(1);
15317 while Present
(Stmt
) loop
15319 -- Skip prior pragmas, but check for duplicates
15321 if Nkind
(Stmt
) = N_Pragma
then
15322 if Pragma_Name
(Stmt
) = Pname
then
15329 -- Skip internally generated code. Note that derived type
15330 -- declarations of untagged types with discriminants are
15331 -- rewritten as private type declarations.
15333 elsif not Comes_From_Source
(Stmt
)
15334 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15338 -- The associated private type [extension] has been found, stop
15341 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
15342 N_Private_Type_Declaration
)
15344 Typ
:= Defining_Entity
(Stmt
);
15347 -- The pragma does not apply to a legal construct, issue an
15348 -- error and stop the analysis.
15355 Stmt
:= Prev
(Stmt
);
15358 -- The pragma does not apply to a legal construct, issue an error
15359 -- and stop the analysis.
15366 -- A pragma that applies to a Ghost entity becomes Ghost for the
15367 -- purposes of legality checks and removal of ignored Ghost code.
15369 Mark_Ghost_Pragma
(N
, Typ
);
15371 -- The pragma signals that the type defines its own DIC assertion
15374 Set_Has_Own_DIC
(Typ
);
15376 -- Chain the pragma on the rep item chain for further processing
15378 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15380 -- Create the declaration of the procedure which verifies the
15381 -- assertion expression of pragma DIC at runtime.
15383 Build_DIC_Procedure_Declaration
(Typ
);
15386 ----------------------------------
15387 -- Default_Scalar_Storage_Order --
15388 ----------------------------------
15390 -- pragma Default_Scalar_Storage_Order
15391 -- (High_Order_First | Low_Order_First);
15393 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15394 Default
: Character;
15398 Check_Arg_Count
(1);
15400 -- Default_Scalar_Storage_Order can appear as a configuration
15401 -- pragma, or in a declarative part of a package spec.
15403 if not Is_Configuration_Pragma
then
15404 Check_Is_In_Decl_Part_Or_Package_Spec
;
15407 Check_No_Identifiers
;
15408 Check_Arg_Is_One_Of
15409 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
15410 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15411 Default
:= Fold_Upper
(Name_Buffer
(1));
15413 if not Support_Nondefault_SSO_On_Target
15414 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
15416 if Warn_On_Unrecognized_Pragma
then
15418 ("non-default Scalar_Storage_Order not supported "
15419 & "on target?g?", N
);
15421 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
15424 -- Here set the specified default
15427 Opt
.Default_SSO
:= Default
;
15431 --------------------------
15432 -- Default_Storage_Pool --
15433 --------------------------
15435 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15437 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
15442 Check_Arg_Count
(1);
15444 -- Default_Storage_Pool can appear as a configuration pragma, or
15445 -- in a declarative part of a package spec.
15447 if not Is_Configuration_Pragma
then
15448 Check_Is_In_Decl_Part_Or_Package_Spec
;
15451 if From_Aspect_Specification
(N
) then
15453 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
15455 if not In_Open_Scopes
(E
) then
15457 ("aspect must apply to package or subprogram", N
);
15462 if Present
(Arg1
) then
15463 Pool
:= Get_Pragma_Arg
(Arg1
);
15465 -- Case of Default_Storage_Pool (null);
15467 if Nkind
(Pool
) = N_Null
then
15470 -- This is an odd case, this is not really an expression,
15471 -- so we don't have a type for it. So just set the type to
15474 Set_Etype
(Pool
, Empty
);
15476 -- Case of Default_Storage_Pool (storage_pool_NAME);
15479 -- If it's a configuration pragma, then the only allowed
15480 -- argument is "null".
15482 if Is_Configuration_Pragma
then
15483 Error_Pragma_Arg
("NULL expected", Arg1
);
15486 -- The expected type for a non-"null" argument is
15487 -- Root_Storage_Pool'Class, and the pool must be a variable.
15489 Analyze_And_Resolve
15490 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
15492 if Is_Variable
(Pool
) then
15494 -- A pragma that applies to a Ghost entity becomes Ghost
15495 -- for the purposes of legality checks and removal of
15496 -- ignored Ghost code.
15498 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
15502 ("default storage pool must be a variable", Arg1
);
15506 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15507 -- access type will use this information to set the appropriate
15508 -- attributes of the access type. If the pragma appears in a
15509 -- generic unit it is ignored, given that it may refer to a
15512 if not Inside_A_Generic
then
15513 Default_Pool
:= Pool
;
15516 end Default_Storage_Pool
;
15522 -- pragma Depends (DEPENDENCY_RELATION);
15524 -- DEPENDENCY_RELATION ::=
15526 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15528 -- DEPENDENCY_CLAUSE ::=
15529 -- OUTPUT_LIST =>[+] INPUT_LIST
15530 -- | NULL_DEPENDENCY_CLAUSE
15532 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15534 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15536 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15538 -- OUTPUT ::= NAME | FUNCTION_RESULT
15541 -- where FUNCTION_RESULT is a function Result attribute_reference
15543 -- Characteristics:
15545 -- * Analysis - The annotation undergoes initial checks to verify
15546 -- the legal placement and context. Secondary checks fully analyze
15547 -- the dependency clauses in:
15549 -- Analyze_Depends_In_Decl_Part
15551 -- * Expansion - None.
15553 -- * Template - The annotation utilizes the generic template of the
15554 -- related subprogram [body] when it is:
15556 -- aspect on subprogram declaration
15557 -- aspect on stand-alone subprogram body
15558 -- pragma on stand-alone subprogram body
15560 -- The annotation must prepare its own template when it is:
15562 -- pragma on subprogram declaration
15564 -- * Globals - Capture of global references must occur after full
15567 -- * Instance - The annotation is instantiated automatically when
15568 -- the related generic subprogram [body] is instantiated except for
15569 -- the "pragma on subprogram declaration" case. In that scenario
15570 -- the annotation must instantiate itself.
15572 when Pragma_Depends
=> Depends
: declare
15574 Spec_Id
: Entity_Id
;
15575 Subp_Decl
: Node_Id
;
15578 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15582 -- Chain the pragma on the contract for further processing by
15583 -- Analyze_Depends_In_Decl_Part.
15585 Add_Contract_Item
(N
, Spec_Id
);
15587 -- Fully analyze the pragma when it appears inside an entry
15588 -- or subprogram body because it cannot benefit from forward
15591 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15593 N_Subprogram_Body_Stub
)
15595 -- The legality checks of pragmas Depends and Global are
15596 -- affected by the SPARK mode in effect and the volatility
15597 -- of the context. In addition these two pragmas are subject
15598 -- to an inherent order:
15603 -- Analyze all these pragmas in the order outlined above
15605 Analyze_If_Present
(Pragma_SPARK_Mode
);
15606 Analyze_If_Present
(Pragma_Volatile_Function
);
15607 Analyze_If_Present
(Pragma_Global
);
15608 Analyze_Depends_In_Decl_Part
(N
);
15613 ---------------------
15614 -- Detect_Blocking --
15615 ---------------------
15617 -- pragma Detect_Blocking;
15619 when Pragma_Detect_Blocking
=>
15621 Check_Arg_Count
(0);
15622 Check_Valid_Configuration_Pragma
;
15623 Detect_Blocking
:= True;
15625 ------------------------------------
15626 -- Disable_Atomic_Synchronization --
15627 ------------------------------------
15629 -- pragma Disable_Atomic_Synchronization [(Entity)];
15631 when Pragma_Disable_Atomic_Synchronization
=>
15633 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
15635 -------------------
15636 -- Discard_Names --
15637 -------------------
15639 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15641 when Pragma_Discard_Names
=> Discard_Names
: declare
15646 Check_Ada_83_Warning
;
15648 -- Deal with configuration pragma case
15650 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
15651 Global_Discard_Names
:= True;
15654 -- Otherwise, check correct appropriate context
15657 Check_Is_In_Decl_Part_Or_Package_Spec
;
15659 if Arg_Count
= 0 then
15661 -- If there is no parameter, then from now on this pragma
15662 -- applies to any enumeration, exception or tagged type
15663 -- defined in the current declarative part, and recursively
15664 -- to any nested scope.
15666 Set_Discard_Names
(Current_Scope
);
15670 Check_Arg_Count
(1);
15671 Check_Optional_Identifier
(Arg1
, Name_On
);
15672 Check_Arg_Is_Local_Name
(Arg1
);
15674 E_Id
:= Get_Pragma_Arg
(Arg1
);
15676 if Etype
(E_Id
) = Any_Type
then
15680 E
:= Entity
(E_Id
);
15682 -- A pragma that applies to a Ghost entity becomes Ghost for
15683 -- the purposes of legality checks and removal of ignored
15686 Mark_Ghost_Pragma
(N
, E
);
15688 if (Is_First_Subtype
(E
)
15690 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
15691 or else Ekind
(E
) = E_Exception
15693 Set_Discard_Names
(E
);
15694 Record_Rep_Item
(E
, N
);
15698 ("inappropriate entity for pragma%", Arg1
);
15704 ------------------------
15705 -- Dispatching_Domain --
15706 ------------------------
15708 -- pragma Dispatching_Domain (EXPRESSION);
15710 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15711 P
: constant Node_Id
:= Parent
(N
);
15717 Check_No_Identifiers
;
15718 Check_Arg_Count
(1);
15720 -- This pragma is born obsolete, but not the aspect
15722 if not From_Aspect_Specification
(N
) then
15724 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15727 if Nkind
(P
) = N_Task_Definition
then
15728 Arg
:= Get_Pragma_Arg
(Arg1
);
15729 Ent
:= Defining_Identifier
(Parent
(P
));
15731 -- A pragma that applies to a Ghost entity becomes Ghost for
15732 -- the purposes of legality checks and removal of ignored Ghost
15735 Mark_Ghost_Pragma
(N
, Ent
);
15737 -- The expression must be analyzed in the special manner
15738 -- described in "Handling of Default and Per-Object
15739 -- Expressions" in sem.ads.
15741 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15743 -- Check duplicate pragma before we chain the pragma in the Rep
15744 -- Item chain of Ent.
15746 Check_Duplicate_Pragma
(Ent
);
15747 Record_Rep_Item
(Ent
, N
);
15749 -- Anything else is incorrect
15754 end Dispatching_Domain
;
15760 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15762 when Pragma_Elaborate
=> Elaborate
: declare
15767 -- Pragma must be in context items list of a compilation unit
15769 if not Is_In_Context_Clause
then
15773 -- Must be at least one argument
15775 if Arg_Count
= 0 then
15776 Error_Pragma
("pragma% requires at least one argument");
15779 -- In Ada 83 mode, there can be no items following it in the
15780 -- context list except other pragmas and implicit with clauses
15781 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15782 -- placement rule does not apply.
15784 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15786 while Present
(Citem
) loop
15787 if Nkind
(Citem
) = N_Pragma
15788 or else (Nkind
(Citem
) = N_With_Clause
15789 and then Implicit_With
(Citem
))
15794 ("(Ada 83) pragma% must be at end of context clause");
15801 -- Finally, the arguments must all be units mentioned in a with
15802 -- clause in the same context clause. Note we already checked (in
15803 -- Par.Prag) that the arguments are all identifiers or selected
15807 Outer
: while Present
(Arg
) loop
15808 Citem
:= First
(List_Containing
(N
));
15809 Inner
: while Citem
/= N
loop
15810 if Nkind
(Citem
) = N_With_Clause
15811 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15813 Set_Elaborate_Present
(Citem
, True);
15814 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15816 -- With the pragma present, elaboration calls on
15817 -- subprograms from the named unit need no further
15818 -- checks, as long as the pragma appears in the current
15819 -- compilation unit. If the pragma appears in some unit
15820 -- in the context, there might still be a need for an
15821 -- Elaborate_All_Desirable from the current compilation
15822 -- to the named unit, so we keep the check enabled. This
15823 -- does not apply in SPARK mode, where we allow pragma
15824 -- Elaborate, but we don't trust it to be right so we
15825 -- will still insist on the Elaborate_All.
15827 if Legacy_Elaboration_Checks
15828 and then In_Extended_Main_Source_Unit
(N
)
15829 and then SPARK_Mode
/= On
15831 Set_Suppress_Elaboration_Warnings
15832 (Entity
(Name
(Citem
)));
15843 ("argument of pragma% is not withed unit", Arg
);
15850 -------------------
15851 -- Elaborate_All --
15852 -------------------
15854 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15856 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15861 Check_Ada_83_Warning
;
15863 -- Pragma must be in context items list of a compilation unit
15865 if not Is_In_Context_Clause
then
15869 -- Must be at least one argument
15871 if Arg_Count
= 0 then
15872 Error_Pragma
("pragma% requires at least one argument");
15875 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15876 -- have to appear at the end of the context clause, but may
15877 -- appear mixed in with other items, even in Ada 83 mode.
15879 -- Final check: the arguments must all be units mentioned in
15880 -- a with clause in the same context clause. Note that we
15881 -- already checked (in Par.Prag) that all the arguments are
15882 -- either identifiers or selected components.
15885 Outr
: while Present
(Arg
) loop
15886 Citem
:= First
(List_Containing
(N
));
15887 Innr
: while Citem
/= N
loop
15888 if Nkind
(Citem
) = N_With_Clause
15889 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15891 Set_Elaborate_All_Present
(Citem
, True);
15892 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15894 -- Suppress warnings and elaboration checks on the named
15895 -- unit if the pragma is in the current compilation, as
15896 -- for pragma Elaborate.
15898 if Legacy_Elaboration_Checks
15899 and then In_Extended_Main_Source_Unit
(N
)
15901 Set_Suppress_Elaboration_Warnings
15902 (Entity
(Name
(Citem
)));
15912 Set_Error_Posted
(N
);
15914 ("argument of pragma% is not withed unit", Arg
);
15921 --------------------
15922 -- Elaborate_Body --
15923 --------------------
15925 -- pragma Elaborate_Body [( library_unit_NAME )];
15927 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15928 Cunit_Node
: Node_Id
;
15929 Cunit_Ent
: Entity_Id
;
15932 Check_Ada_83_Warning
;
15933 Check_Valid_Library_Unit_Pragma
;
15935 if Nkind
(N
) = N_Null_Statement
then
15939 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15940 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15942 -- A pragma that applies to a Ghost entity becomes Ghost for the
15943 -- purposes of legality checks and removal of ignored Ghost code.
15945 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15947 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15950 Error_Pragma
("pragma% must refer to a spec, not a body");
15952 Set_Body_Required
(Cunit_Node
);
15953 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15955 -- If we are in dynamic elaboration mode, then we suppress
15956 -- elaboration warnings for the unit, since it is definitely
15957 -- fine NOT to do dynamic checks at the first level (and such
15958 -- checks will be suppressed because no elaboration boolean
15959 -- is created for Elaborate_Body packages).
15961 -- But in the static model of elaboration, Elaborate_Body is
15962 -- definitely NOT good enough to ensure elaboration safety on
15963 -- its own, since the body may WITH other units that are not
15964 -- safe from an elaboration point of view, so a client must
15965 -- still do an Elaborate_All on such units.
15967 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15968 -- Elaborate_Body always suppressed elab warnings.
15970 if Legacy_Elaboration_Checks
15971 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15973 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15976 end Elaborate_Body
;
15978 ------------------------
15979 -- Elaboration_Checks --
15980 ------------------------
15982 -- pragma Elaboration_Checks (Static | Dynamic);
15984 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
15985 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
15986 -- Emit an error if the current context list already contains
15987 -- a previous Elaboration_Checks pragma. This routine raises
15988 -- Pragma_Exit if a duplicate is found.
15990 procedure Ignore_Elaboration_Checks_Pragma
;
15991 -- Warn that the effects of the pragma are ignored. This routine
15992 -- raises Pragma_Exit.
15994 -----------------------------------------------
15995 -- Check_Duplicate_Elaboration_Checks_Pragma --
15996 -----------------------------------------------
15998 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16003 while Present
(Item
) loop
16004 if Nkind
(Item
) = N_Pragma
16005 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16015 end Check_Duplicate_Elaboration_Checks_Pragma
;
16017 --------------------------------------
16018 -- Ignore_Elaboration_Checks_Pragma --
16019 --------------------------------------
16021 procedure Ignore_Elaboration_Checks_Pragma
is
16023 Error_Msg_Name_1
:= Pname
;
16024 Error_Msg_N
("??effects of pragma % are ignored", N
);
16026 ("\place pragma on initial declaration of library unit", N
);
16029 end Ignore_Elaboration_Checks_Pragma
;
16033 Context
: constant Node_Id
:= Parent
(N
);
16036 -- Start of processing for Elaboration_Checks
16040 Check_Arg_Count
(1);
16041 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16043 -- The pragma appears in a configuration file
16045 if No
(Context
) then
16046 Check_Valid_Configuration_Pragma
;
16047 Check_Duplicate_Elaboration_Checks_Pragma
;
16049 -- The pragma acts as a configuration pragma in a compilation unit
16051 -- pragma Elaboration_Checks (...);
16052 -- package Pack is ...;
16054 elsif Nkind
(Context
) = N_Compilation_Unit
16055 and then List_Containing
(N
) = Context_Items
(Context
)
16057 Check_Valid_Configuration_Pragma
;
16058 Check_Duplicate_Elaboration_Checks_Pragma
;
16060 Unt
:= Unit
(Context
);
16062 -- The pragma must appear on the initial declaration of a unit.
16063 -- If this is not the case, warn that the effects of the pragma
16066 if Nkind
(Unt
) = N_Package_Body
then
16067 Ignore_Elaboration_Checks_Pragma
;
16069 -- Check the Acts_As_Spec flag of the compilation units itself
16070 -- to determine whether the subprogram body completes since it
16071 -- has not been analyzed yet. This is safe because compilation
16072 -- units are not overloadable.
16074 elsif Nkind
(Unt
) = N_Subprogram_Body
16075 and then not Acts_As_Spec
(Context
)
16077 Ignore_Elaboration_Checks_Pragma
;
16079 elsif Nkind
(Unt
) = N_Subunit
then
16080 Ignore_Elaboration_Checks_Pragma
;
16083 -- Otherwise the pragma does not appear at the configuration level
16090 -- At this point the pragma is not a duplicate, and appears in the
16091 -- proper context. Set the elaboration model in effect.
16093 Dynamic_Elaboration_Checks
:=
16094 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16095 end Elaboration_Checks
;
16101 -- pragma Eliminate (
16102 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16103 -- [Entity =>] IDENTIFIER |
16104 -- SELECTED_COMPONENT |
16106 -- [, Source_Location => SOURCE_TRACE]);
16108 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16109 -- SOURCE_TRACE ::= STRING_LITERAL
16111 when Pragma_Eliminate
=> Eliminate
: declare
16112 Args
: Args_List
(1 .. 5);
16113 Names
: constant Name_List
(1 .. 5) := (
16116 Name_Parameter_Types
,
16118 Name_Source_Location
);
16120 -- Note : Parameter_Types and Result_Type are leftovers from
16121 -- prior implementations of the pragma. They are not generated
16122 -- by the gnatelim tool, and play no role in selecting which
16123 -- of a set of overloaded names is chosen for elimination.
16125 Unit_Name
: Node_Id
renames Args
(1);
16126 Entity
: Node_Id
renames Args
(2);
16127 Parameter_Types
: Node_Id
renames Args
(3);
16128 Result_Type
: Node_Id
renames Args
(4);
16129 Source_Location
: Node_Id
renames Args
(5);
16133 Check_Valid_Configuration_Pragma
;
16134 Gather_Associations
(Names
, Args
);
16136 if No
(Unit_Name
) then
16137 Error_Pragma
("missing Unit_Name argument for pragma%");
16141 and then (Present
(Parameter_Types
)
16143 Present
(Result_Type
)
16145 Present
(Source_Location
))
16147 Error_Pragma
("missing Entity argument for pragma%");
16150 if (Present
(Parameter_Types
)
16152 Present
(Result_Type
))
16154 Present
(Source_Location
)
16157 ("parameter profile and source location cannot be used "
16158 & "together in pragma%");
16161 Process_Eliminate_Pragma
16170 -----------------------------------
16171 -- Enable_Atomic_Synchronization --
16172 -----------------------------------
16174 -- pragma Enable_Atomic_Synchronization [(Entity)];
16176 when Pragma_Enable_Atomic_Synchronization
=>
16178 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16185 -- [ Convention =>] convention_IDENTIFIER,
16186 -- [ Entity =>] LOCAL_NAME
16187 -- [, [External_Name =>] static_string_EXPRESSION ]
16188 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16190 when Pragma_Export
=> Export
: declare
16192 Def_Id
: Entity_Id
;
16194 pragma Warnings
(Off
, C
);
16197 Check_Ada_83_Warning
;
16201 Name_External_Name
,
16204 Check_At_Least_N_Arguments
(2);
16205 Check_At_Most_N_Arguments
(4);
16207 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16208 -- pragma Export (Entity, "external name");
16210 if Relaxed_RM_Semantics
16211 and then Arg_Count
= 2
16212 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16215 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16218 if not Is_Entity_Name
(Def_Id
) then
16219 Error_Pragma_Arg
("entity name required", Arg1
);
16222 Def_Id
:= Entity
(Def_Id
);
16223 Set_Exported
(Def_Id
, Arg1
);
16226 Process_Convention
(C
, Def_Id
);
16228 -- A pragma that applies to a Ghost entity becomes Ghost for
16229 -- the purposes of legality checks and removal of ignored Ghost
16232 Mark_Ghost_Pragma
(N
, Def_Id
);
16234 if Ekind
(Def_Id
) /= E_Constant
then
16235 Note_Possible_Modification
16236 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16239 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
16240 Set_Exported
(Def_Id
, Arg2
);
16243 -- If the entity is a deferred constant, propagate the information
16244 -- to the full view, because gigi elaborates the full view only.
16246 if Ekind
(Def_Id
) = E_Constant
16247 and then Present
(Full_View
(Def_Id
))
16250 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
16252 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
16253 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
16254 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
16259 ---------------------
16260 -- Export_Function --
16261 ---------------------
16263 -- pragma Export_Function (
16264 -- [Internal =>] LOCAL_NAME
16265 -- [, [External =>] EXTERNAL_SYMBOL]
16266 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16267 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16268 -- [, [Mechanism =>] MECHANISM]
16269 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16271 -- EXTERNAL_SYMBOL ::=
16273 -- | static_string_EXPRESSION
16275 -- PARAMETER_TYPES ::=
16277 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16279 -- TYPE_DESIGNATOR ::=
16281 -- | subtype_Name ' Access
16285 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16287 -- MECHANISM_ASSOCIATION ::=
16288 -- [formal_parameter_NAME =>] MECHANISM_NAME
16290 -- MECHANISM_NAME ::=
16294 when Pragma_Export_Function
=> Export_Function
: declare
16295 Args
: Args_List
(1 .. 6);
16296 Names
: constant Name_List
(1 .. 6) := (
16299 Name_Parameter_Types
,
16302 Name_Result_Mechanism
);
16304 Internal
: Node_Id
renames Args
(1);
16305 External
: Node_Id
renames Args
(2);
16306 Parameter_Types
: Node_Id
renames Args
(3);
16307 Result_Type
: Node_Id
renames Args
(4);
16308 Mechanism
: Node_Id
renames Args
(5);
16309 Result_Mechanism
: Node_Id
renames Args
(6);
16313 Gather_Associations
(Names
, Args
);
16314 Process_Extended_Import_Export_Subprogram_Pragma
(
16315 Arg_Internal
=> Internal
,
16316 Arg_External
=> External
,
16317 Arg_Parameter_Types
=> Parameter_Types
,
16318 Arg_Result_Type
=> Result_Type
,
16319 Arg_Mechanism
=> Mechanism
,
16320 Arg_Result_Mechanism
=> Result_Mechanism
);
16321 end Export_Function
;
16323 -------------------
16324 -- Export_Object --
16325 -------------------
16327 -- pragma Export_Object (
16328 -- [Internal =>] LOCAL_NAME
16329 -- [, [External =>] EXTERNAL_SYMBOL]
16330 -- [, [Size =>] EXTERNAL_SYMBOL]);
16332 -- EXTERNAL_SYMBOL ::=
16334 -- | static_string_EXPRESSION
16336 -- PARAMETER_TYPES ::=
16338 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16340 -- TYPE_DESIGNATOR ::=
16342 -- | subtype_Name ' Access
16346 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16348 -- MECHANISM_ASSOCIATION ::=
16349 -- [formal_parameter_NAME =>] MECHANISM_NAME
16351 -- MECHANISM_NAME ::=
16355 when Pragma_Export_Object
=> Export_Object
: declare
16356 Args
: Args_List
(1 .. 3);
16357 Names
: constant Name_List
(1 .. 3) := (
16362 Internal
: Node_Id
renames Args
(1);
16363 External
: Node_Id
renames Args
(2);
16364 Size
: Node_Id
renames Args
(3);
16368 Gather_Associations
(Names
, Args
);
16369 Process_Extended_Import_Export_Object_Pragma
(
16370 Arg_Internal
=> Internal
,
16371 Arg_External
=> External
,
16375 ----------------------
16376 -- Export_Procedure --
16377 ----------------------
16379 -- pragma Export_Procedure (
16380 -- [Internal =>] LOCAL_NAME
16381 -- [, [External =>] EXTERNAL_SYMBOL]
16382 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16383 -- [, [Mechanism =>] MECHANISM]);
16385 -- EXTERNAL_SYMBOL ::=
16387 -- | static_string_EXPRESSION
16389 -- PARAMETER_TYPES ::=
16391 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16393 -- TYPE_DESIGNATOR ::=
16395 -- | subtype_Name ' Access
16399 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16401 -- MECHANISM_ASSOCIATION ::=
16402 -- [formal_parameter_NAME =>] MECHANISM_NAME
16404 -- MECHANISM_NAME ::=
16408 when Pragma_Export_Procedure
=> Export_Procedure
: declare
16409 Args
: Args_List
(1 .. 4);
16410 Names
: constant Name_List
(1 .. 4) := (
16413 Name_Parameter_Types
,
16416 Internal
: Node_Id
renames Args
(1);
16417 External
: Node_Id
renames Args
(2);
16418 Parameter_Types
: Node_Id
renames Args
(3);
16419 Mechanism
: Node_Id
renames Args
(4);
16423 Gather_Associations
(Names
, Args
);
16424 Process_Extended_Import_Export_Subprogram_Pragma
(
16425 Arg_Internal
=> Internal
,
16426 Arg_External
=> External
,
16427 Arg_Parameter_Types
=> Parameter_Types
,
16428 Arg_Mechanism
=> Mechanism
);
16429 end Export_Procedure
;
16435 -- pragma Export_Value (
16436 -- [Value =>] static_integer_EXPRESSION,
16437 -- [Link_Name =>] static_string_EXPRESSION);
16439 when Pragma_Export_Value
=>
16441 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
16442 Check_Arg_Count
(2);
16444 Check_Optional_Identifier
(Arg1
, Name_Value
);
16445 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16447 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
16448 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16450 -----------------------------
16451 -- Export_Valued_Procedure --
16452 -----------------------------
16454 -- pragma Export_Valued_Procedure (
16455 -- [Internal =>] LOCAL_NAME
16456 -- [, [External =>] EXTERNAL_SYMBOL,]
16457 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16458 -- [, [Mechanism =>] MECHANISM]);
16460 -- EXTERNAL_SYMBOL ::=
16462 -- | static_string_EXPRESSION
16464 -- PARAMETER_TYPES ::=
16466 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16468 -- TYPE_DESIGNATOR ::=
16470 -- | subtype_Name ' Access
16474 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16476 -- MECHANISM_ASSOCIATION ::=
16477 -- [formal_parameter_NAME =>] MECHANISM_NAME
16479 -- MECHANISM_NAME ::=
16483 when Pragma_Export_Valued_Procedure
=>
16484 Export_Valued_Procedure
: declare
16485 Args
: Args_List
(1 .. 4);
16486 Names
: constant Name_List
(1 .. 4) := (
16489 Name_Parameter_Types
,
16492 Internal
: Node_Id
renames Args
(1);
16493 External
: Node_Id
renames Args
(2);
16494 Parameter_Types
: Node_Id
renames Args
(3);
16495 Mechanism
: Node_Id
renames Args
(4);
16499 Gather_Associations
(Names
, Args
);
16500 Process_Extended_Import_Export_Subprogram_Pragma
(
16501 Arg_Internal
=> Internal
,
16502 Arg_External
=> External
,
16503 Arg_Parameter_Types
=> Parameter_Types
,
16504 Arg_Mechanism
=> Mechanism
);
16505 end Export_Valued_Procedure
;
16507 -------------------
16508 -- Extend_System --
16509 -------------------
16511 -- pragma Extend_System ([Name =>] Identifier);
16513 when Pragma_Extend_System
=>
16515 Check_Valid_Configuration_Pragma
;
16516 Check_Arg_Count
(1);
16517 Check_Optional_Identifier
(Arg1
, Name_Name
);
16518 Check_Arg_Is_Identifier
(Arg1
);
16520 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16523 and then Name_Buffer
(1 .. 4) = "aux_"
16525 if Present
(System_Extend_Pragma_Arg
) then
16526 if Chars
(Get_Pragma_Arg
(Arg1
)) =
16527 Chars
(Expression
(System_Extend_Pragma_Arg
))
16531 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
16532 Error_Pragma
("pragma% conflicts with that #");
16536 System_Extend_Pragma_Arg
:= Arg1
;
16538 if not GNAT_Mode
then
16539 System_Extend_Unit
:= Arg1
;
16543 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
16546 ------------------------
16547 -- Extensions_Allowed --
16548 ------------------------
16550 -- pragma Extensions_Allowed (ON | OFF);
16552 when Pragma_Extensions_Allowed
=>
16554 Check_Arg_Count
(1);
16555 Check_No_Identifiers
;
16556 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
16558 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
16559 Extensions_Allowed
:= True;
16560 Ada_Version
:= Ada_Version_Type
'Last;
16563 Extensions_Allowed
:= False;
16564 Ada_Version
:= Ada_Version_Explicit
;
16565 Ada_Version_Pragma
:= Empty
;
16568 ------------------------
16569 -- Extensions_Visible --
16570 ------------------------
16572 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16574 -- Characteristics:
16576 -- * Analysis - The annotation is fully analyzed immediately upon
16577 -- elaboration as its expression must be static.
16579 -- * Expansion - None.
16581 -- * Template - The annotation utilizes the generic template of the
16582 -- related subprogram [body] when it is:
16584 -- aspect on subprogram declaration
16585 -- aspect on stand-alone subprogram body
16586 -- pragma on stand-alone subprogram body
16588 -- The annotation must prepare its own template when it is:
16590 -- pragma on subprogram declaration
16592 -- * Globals - Capture of global references must occur after full
16595 -- * Instance - The annotation is instantiated automatically when
16596 -- the related generic subprogram [body] is instantiated except for
16597 -- the "pragma on subprogram declaration" case. In that scenario
16598 -- the annotation must instantiate itself.
16600 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
16601 Formal
: Entity_Id
;
16602 Has_OK_Formal
: Boolean := False;
16603 Spec_Id
: Entity_Id
;
16604 Subp_Decl
: Node_Id
;
16608 Check_No_Identifiers
;
16609 Check_At_Most_N_Arguments
(1);
16612 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16614 -- Abstract subprogram declaration
16616 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
16619 -- Generic subprogram declaration
16621 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16624 -- Body acts as spec
16626 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16627 and then No
(Corresponding_Spec
(Subp_Decl
))
16631 -- Body stub acts as spec
16633 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16634 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16638 -- Subprogram declaration
16640 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16643 -- Otherwise the pragma is associated with an illegal construct
16646 Error_Pragma
("pragma % must apply to a subprogram");
16650 -- Mark the pragma as Ghost if the related subprogram is also
16651 -- Ghost. This also ensures that any expansion performed further
16652 -- below will produce Ghost nodes.
16654 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16655 Mark_Ghost_Pragma
(N
, Spec_Id
);
16657 -- Chain the pragma on the contract for completeness
16659 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16661 -- The legality checks of pragma Extension_Visible are affected
16662 -- by the SPARK mode in effect. Analyze all pragmas in specific
16665 Analyze_If_Present
(Pragma_SPARK_Mode
);
16667 -- Examine the formals of the related subprogram
16669 Formal
:= First_Formal
(Spec_Id
);
16670 while Present
(Formal
) loop
16672 -- At least one of the formals is of a specific tagged type,
16673 -- the pragma is legal.
16675 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
16676 Has_OK_Formal
:= True;
16679 -- A generic subprogram with at least one formal of a private
16680 -- type ensures the legality of the pragma because the actual
16681 -- may be specifically tagged. Note that this is verified by
16682 -- the check above at instantiation time.
16684 elsif Is_Private_Type
(Etype
(Formal
))
16685 and then Is_Generic_Type
(Etype
(Formal
))
16687 Has_OK_Formal
:= True;
16691 Next_Formal
(Formal
);
16694 if not Has_OK_Formal
then
16695 Error_Msg_Name_1
:= Pname
;
16696 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
16698 ("\subprogram & lacks parameter of specific tagged or "
16699 & "generic private type", N
, Spec_Id
);
16704 -- Analyze the Boolean expression (if any)
16706 if Present
(Arg1
) then
16707 Check_Static_Boolean_Expression
16708 (Expression
(Get_Argument
(N
, Spec_Id
)));
16710 end Extensions_Visible
;
16716 -- pragma External (
16717 -- [ Convention =>] convention_IDENTIFIER,
16718 -- [ Entity =>] LOCAL_NAME
16719 -- [, [External_Name =>] static_string_EXPRESSION ]
16720 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16722 when Pragma_External
=> External
: declare
16725 pragma Warnings
(Off
, C
);
16732 Name_External_Name
,
16734 Check_At_Least_N_Arguments
(2);
16735 Check_At_Most_N_Arguments
(4);
16736 Process_Convention
(C
, E
);
16738 -- A pragma that applies to a Ghost entity becomes Ghost for the
16739 -- purposes of legality checks and removal of ignored Ghost code.
16741 Mark_Ghost_Pragma
(N
, E
);
16743 Note_Possible_Modification
16744 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16745 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16746 Set_Exported
(E
, Arg2
);
16749 --------------------------
16750 -- External_Name_Casing --
16751 --------------------------
16753 -- pragma External_Name_Casing (
16754 -- UPPERCASE | LOWERCASE
16755 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16757 when Pragma_External_Name_Casing
=>
16759 Check_No_Identifiers
;
16761 if Arg_Count
= 2 then
16762 Check_Arg_Is_One_Of
16763 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16765 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16767 Opt
.External_Name_Exp_Casing
:= As_Is
;
16769 when Name_Uppercase
=>
16770 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16772 when Name_Lowercase
=>
16773 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16780 Check_Arg_Count
(1);
16783 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16785 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16786 when Name_Uppercase
=>
16787 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16789 when Name_Lowercase
=>
16790 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16800 -- pragma Fast_Math;
16802 when Pragma_Fast_Math
=>
16804 Check_No_Identifiers
;
16805 Check_Valid_Configuration_Pragma
;
16808 --------------------------
16809 -- Favor_Top_Level --
16810 --------------------------
16812 -- pragma Favor_Top_Level (type_NAME);
16814 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16819 Check_No_Identifiers
;
16820 Check_Arg_Count
(1);
16821 Check_Arg_Is_Local_Name
(Arg1
);
16822 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16824 -- A pragma that applies to a Ghost entity becomes Ghost for the
16825 -- purposes of legality checks and removal of ignored Ghost code.
16827 Mark_Ghost_Pragma
(N
, Typ
);
16829 -- If it's an access-to-subprogram type (in particular, not a
16830 -- subtype), set the flag on that type.
16832 if Is_Access_Subprogram_Type
(Typ
) then
16833 Set_Can_Use_Internal_Rep
(Typ
, False);
16835 -- Otherwise it's an error (name denotes the wrong sort of entity)
16839 ("access-to-subprogram type expected",
16840 Get_Pragma_Arg
(Arg1
));
16842 end Favor_Top_Level
;
16844 ---------------------------
16845 -- Finalize_Storage_Only --
16846 ---------------------------
16848 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16850 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16851 Assoc
: constant Node_Id
:= Arg1
;
16852 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16857 Check_No_Identifiers
;
16858 Check_Arg_Count
(1);
16859 Check_Arg_Is_Local_Name
(Arg1
);
16861 Find_Type
(Type_Id
);
16862 Typ
:= Entity
(Type_Id
);
16865 or else Rep_Item_Too_Early
(Typ
, N
)
16869 Typ
:= Underlying_Type
(Typ
);
16872 if not Is_Controlled
(Typ
) then
16873 Error_Pragma
("pragma% must specify controlled type");
16876 Check_First_Subtype
(Arg1
);
16878 if Finalize_Storage_Only
(Typ
) then
16879 Error_Pragma
("duplicate pragma%, only one allowed");
16881 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16882 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16884 end Finalize_Storage
;
16890 -- pragma Ghost [ (boolean_EXPRESSION) ];
16892 when Pragma_Ghost
=> Ghost
: declare
16896 Orig_Stmt
: Node_Id
;
16897 Prev_Id
: Entity_Id
;
16902 Check_No_Identifiers
;
16903 Check_At_Most_N_Arguments
(1);
16907 while Present
(Stmt
) loop
16909 -- Skip prior pragmas, but check for duplicates
16911 if Nkind
(Stmt
) = N_Pragma
then
16912 if Pragma_Name
(Stmt
) = Pname
then
16919 -- Task unit declared without a definition cannot be subject to
16920 -- pragma Ghost (SPARK RM 6.9(19)).
16922 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16923 N_Task_Type_Declaration
)
16925 Error_Pragma
("pragma % cannot apply to a task type");
16928 -- Skip internally generated code
16930 elsif not Comes_From_Source
(Stmt
) then
16931 Orig_Stmt
:= Original_Node
(Stmt
);
16933 -- When pragma Ghost applies to an untagged derivation, the
16934 -- derivation is transformed into a [sub]type declaration.
16936 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16937 N_Subtype_Declaration
)
16938 and then Comes_From_Source
(Orig_Stmt
)
16939 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16940 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16941 N_Derived_Type_Definition
16943 Id
:= Defining_Entity
(Stmt
);
16946 -- When pragma Ghost applies to an object declaration which
16947 -- is initialized by means of a function call that returns
16948 -- on the secondary stack, the object declaration becomes a
16951 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16952 and then Comes_From_Source
(Orig_Stmt
)
16953 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16955 Id
:= Defining_Entity
(Stmt
);
16958 -- When pragma Ghost applies to an expression function, the
16959 -- expression function is transformed into a subprogram.
16961 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16962 and then Comes_From_Source
(Orig_Stmt
)
16963 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16965 Id
:= Defining_Entity
(Stmt
);
16969 -- The pragma applies to a legal construct, stop the traversal
16971 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16972 N_Full_Type_Declaration
,
16973 N_Generic_Subprogram_Declaration
,
16974 N_Object_Declaration
,
16975 N_Private_Extension_Declaration
,
16976 N_Private_Type_Declaration
,
16977 N_Subprogram_Declaration
,
16978 N_Subtype_Declaration
)
16980 Id
:= Defining_Entity
(Stmt
);
16983 -- The pragma does not apply to a legal construct, issue an
16984 -- error and stop the analysis.
16988 ("pragma % must apply to an object, package, subprogram "
16993 Stmt
:= Prev
(Stmt
);
16996 Context
:= Parent
(N
);
16998 -- Handle compilation units
17000 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17001 Context
:= Unit
(Parent
(Context
));
17004 -- Protected and task types cannot be subject to pragma Ghost
17005 -- (SPARK RM 6.9(19)).
17007 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
17009 Error_Pragma
("pragma % cannot apply to a protected type");
17012 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
17013 Error_Pragma
("pragma % cannot apply to a task type");
17019 -- When pragma Ghost is associated with a [generic] package, it
17020 -- appears in the visible declarations.
17022 if Nkind
(Context
) = N_Package_Specification
17023 and then Present
(Visible_Declarations
(Context
))
17024 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17026 Id
:= Defining_Entity
(Context
);
17028 -- Pragma Ghost applies to a stand-alone subprogram body
17030 elsif Nkind
(Context
) = N_Subprogram_Body
17031 and then No
(Corresponding_Spec
(Context
))
17033 Id
:= Defining_Entity
(Context
);
17035 -- Pragma Ghost applies to a subprogram declaration that acts
17036 -- as a compilation unit.
17038 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17039 Id
:= Defining_Entity
(Context
);
17041 -- Pragma Ghost applies to a generic subprogram
17043 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17044 Id
:= Defining_Entity
(Specification
(Context
));
17050 ("pragma % must apply to an object, package, subprogram or "
17055 -- Handle completions of types and constants that are subject to
17058 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17059 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17061 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17062 Error_Msg_Name_1
:= Pname
;
17064 -- The full declaration of a deferred constant cannot be
17065 -- subject to pragma Ghost unless the deferred declaration
17066 -- is also Ghost (SPARK RM 6.9(9)).
17068 if Ekind
(Prev_Id
) = E_Constant
then
17069 Error_Msg_Name_1
:= Pname
;
17070 Error_Msg_NE
(Fix_Error
17071 ("pragma % must apply to declaration of deferred "
17072 & "constant &"), N
, Id
);
17075 -- Pragma Ghost may appear on the full view of an incomplete
17076 -- type because the incomplete declaration lacks aspects and
17077 -- cannot be subject to pragma Ghost.
17079 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17082 -- The full declaration of a type cannot be subject to
17083 -- pragma Ghost unless the partial view is also Ghost
17084 -- (SPARK RM 6.9(9)).
17087 Error_Msg_NE
(Fix_Error
17088 ("pragma % must apply to partial view of type &"),
17094 -- A synchronized object cannot be subject to pragma Ghost
17095 -- (SPARK RM 6.9(19)).
17097 elsif Ekind
(Id
) = E_Variable
then
17098 if Is_Protected_Type
(Etype
(Id
)) then
17099 Error_Pragma
("pragma % cannot apply to a protected object");
17102 elsif Is_Task_Type
(Etype
(Id
)) then
17103 Error_Pragma
("pragma % cannot apply to a task object");
17108 -- Analyze the Boolean expression (if any)
17110 if Present
(Arg1
) then
17111 Expr
:= Get_Pragma_Arg
(Arg1
);
17113 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17115 if Is_OK_Static_Expression
(Expr
) then
17117 -- "Ghostness" cannot be turned off once enabled within a
17118 -- region (SPARK RM 6.9(6)).
17120 if Is_False
(Expr_Value
(Expr
))
17121 and then Ghost_Mode
> None
17124 ("pragma % with value False cannot appear in enabled "
17129 -- Otherwie the expression is not static
17133 ("expression of pragma % must be static", Expr
);
17138 Set_Is_Ghost_Entity
(Id
);
17145 -- pragma Global (GLOBAL_SPECIFICATION);
17147 -- GLOBAL_SPECIFICATION ::=
17150 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17152 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17154 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17155 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17156 -- GLOBAL_ITEM ::= NAME
17158 -- Characteristics:
17160 -- * Analysis - The annotation undergoes initial checks to verify
17161 -- the legal placement and context. Secondary checks fully analyze
17162 -- the dependency clauses in:
17164 -- Analyze_Global_In_Decl_Part
17166 -- * Expansion - None.
17168 -- * Template - The annotation utilizes the generic template of the
17169 -- related subprogram [body] when it is:
17171 -- aspect on subprogram declaration
17172 -- aspect on stand-alone subprogram body
17173 -- pragma on stand-alone subprogram body
17175 -- The annotation must prepare its own template when it is:
17177 -- pragma on subprogram declaration
17179 -- * Globals - Capture of global references must occur after full
17182 -- * Instance - The annotation is instantiated automatically when
17183 -- the related generic subprogram [body] is instantiated except for
17184 -- the "pragma on subprogram declaration" case. In that scenario
17185 -- the annotation must instantiate itself.
17187 when Pragma_Global
=> Global
: declare
17189 Spec_Id
: Entity_Id
;
17190 Subp_Decl
: Node_Id
;
17193 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17197 -- Chain the pragma on the contract for further processing by
17198 -- Analyze_Global_In_Decl_Part.
17200 Add_Contract_Item
(N
, Spec_Id
);
17202 -- Fully analyze the pragma when it appears inside an entry
17203 -- or subprogram body because it cannot benefit from forward
17206 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
17208 N_Subprogram_Body_Stub
)
17210 -- The legality checks of pragmas Depends and Global are
17211 -- affected by the SPARK mode in effect and the volatility
17212 -- of the context. In addition these two pragmas are subject
17213 -- to an inherent order:
17218 -- Analyze all these pragmas in the order outlined above
17220 Analyze_If_Present
(Pragma_SPARK_Mode
);
17221 Analyze_If_Present
(Pragma_Volatile_Function
);
17222 Analyze_Global_In_Decl_Part
(N
);
17223 Analyze_If_Present
(Pragma_Depends
);
17232 -- pragma Ident (static_string_EXPRESSION)
17234 -- Note: pragma Comment shares this processing. Pragma Ident is
17235 -- identical in effect to pragma Commment.
17237 when Pragma_Comment
17245 Check_Arg_Count
(1);
17246 Check_No_Identifiers
;
17247 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17250 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
17257 GP
:= Parent
(Parent
(N
));
17259 if Nkind_In
(GP
, N_Package_Declaration
,
17260 N_Generic_Package_Declaration
)
17265 -- If we have a compilation unit, then record the ident value,
17266 -- checking for improper duplication.
17268 if Nkind
(GP
) = N_Compilation_Unit
then
17269 CS
:= Ident_String
(Current_Sem_Unit
);
17271 if Present
(CS
) then
17273 -- If we have multiple instances, concatenate them, but
17274 -- not in ASIS, where we want the original tree.
17276 if not ASIS_Mode
then
17277 Start_String
(Strval
(CS
));
17278 Store_String_Char
(' ');
17279 Store_String_Chars
(Strval
(Str
));
17280 Set_Strval
(CS
, End_String
);
17284 Set_Ident_String
(Current_Sem_Unit
, Str
);
17287 -- For subunits, we just ignore the Ident, since in GNAT these
17288 -- are not separate object files, and hence not separate units
17289 -- in the unit table.
17291 elsif Nkind
(GP
) = N_Subunit
then
17297 -------------------
17298 -- Ignore_Pragma --
17299 -------------------
17301 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17303 -- Entirely handled in the parser, nothing to do here
17305 when Pragma_Ignore_Pragma
=>
17308 ----------------------------
17309 -- Implementation_Defined --
17310 ----------------------------
17312 -- pragma Implementation_Defined (LOCAL_NAME);
17314 -- Marks previously declared entity as implementation defined. For
17315 -- an overloaded entity, applies to the most recent homonym.
17317 -- pragma Implementation_Defined;
17319 -- The form with no arguments appears anywhere within a scope, most
17320 -- typically a package spec, and indicates that all entities that are
17321 -- defined within the package spec are Implementation_Defined.
17323 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
17328 Check_No_Identifiers
;
17330 -- Form with no arguments
17332 if Arg_Count
= 0 then
17333 Set_Is_Implementation_Defined
(Current_Scope
);
17335 -- Form with one argument
17338 Check_Arg_Count
(1);
17339 Check_Arg_Is_Local_Name
(Arg1
);
17340 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17341 Set_Is_Implementation_Defined
(Ent
);
17343 end Implementation_Defined
;
17349 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17351 -- IMPLEMENTATION_KIND ::=
17352 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17354 -- "By_Any" and "Optional" are treated as synonyms in order to
17355 -- support Ada 2012 aspect Synchronization.
17357 when Pragma_Implemented
=> Implemented
: declare
17358 Proc_Id
: Entity_Id
;
17363 Check_Arg_Count
(2);
17364 Check_No_Identifiers
;
17365 Check_Arg_Is_Identifier
(Arg1
);
17366 Check_Arg_Is_Local_Name
(Arg1
);
17367 Check_Arg_Is_One_Of
(Arg2
,
17370 Name_By_Protected_Procedure
,
17373 -- Extract the name of the local procedure
17375 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17377 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17378 -- primitive procedure of a synchronized tagged type.
17380 if Ekind
(Proc_Id
) = E_Procedure
17381 and then Is_Primitive
(Proc_Id
)
17382 and then Present
(First_Formal
(Proc_Id
))
17384 Typ
:= Etype
(First_Formal
(Proc_Id
));
17386 if Is_Tagged_Type
(Typ
)
17389 -- Check for a protected, a synchronized or a task interface
17391 ((Is_Interface
(Typ
)
17392 and then Is_Synchronized_Interface
(Typ
))
17394 -- Check for a protected type or a task type that implements
17398 (Is_Concurrent_Record_Type
(Typ
)
17399 and then Present
(Interfaces
(Typ
)))
17401 -- In analysis-only mode, examine original protected type
17404 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
17405 and then Present
(Interface_List
(Parent
(Typ
))))
17407 -- Check for a private record extension with keyword
17411 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
17412 E_Record_Subtype_With_Private
)
17413 and then Synchronized_Present
(Parent
(Typ
))))
17418 ("controlling formal must be of synchronized tagged type",
17423 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17424 -- By_Protected_Procedure to the primitive procedure of a task
17427 if Chars
(Arg2
) = Name_By_Protected_Procedure
17428 and then Is_Interface
(Typ
)
17429 and then Is_Task_Interface
(Typ
)
17432 ("implementation kind By_Protected_Procedure cannot be "
17433 & "applied to a task interface primitive", Arg2
);
17437 -- Procedures declared inside a protected type must be accepted
17439 elsif Ekind
(Proc_Id
) = E_Procedure
17440 and then Is_Protected_Type
(Scope
(Proc_Id
))
17444 -- The first argument is not a primitive procedure
17448 ("pragma % must be applied to a primitive procedure", Arg1
);
17452 Record_Rep_Item
(Proc_Id
, N
);
17455 ----------------------
17456 -- Implicit_Packing --
17457 ----------------------
17459 -- pragma Implicit_Packing;
17461 when Pragma_Implicit_Packing
=>
17463 Check_Arg_Count
(0);
17464 Implicit_Packing
:= True;
17471 -- [Convention =>] convention_IDENTIFIER,
17472 -- [Entity =>] LOCAL_NAME
17473 -- [, [External_Name =>] static_string_EXPRESSION ]
17474 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17476 when Pragma_Import
=>
17477 Check_Ada_83_Warning
;
17481 Name_External_Name
,
17484 Check_At_Least_N_Arguments
(2);
17485 Check_At_Most_N_Arguments
(4);
17486 Process_Import_Or_Interface
;
17488 ---------------------
17489 -- Import_Function --
17490 ---------------------
17492 -- pragma Import_Function (
17493 -- [Internal =>] LOCAL_NAME,
17494 -- [, [External =>] EXTERNAL_SYMBOL]
17495 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17496 -- [, [Result_Type =>] SUBTYPE_MARK]
17497 -- [, [Mechanism =>] MECHANISM]
17498 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17500 -- EXTERNAL_SYMBOL ::=
17502 -- | static_string_EXPRESSION
17504 -- PARAMETER_TYPES ::=
17506 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17508 -- TYPE_DESIGNATOR ::=
17510 -- | subtype_Name ' Access
17514 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17516 -- MECHANISM_ASSOCIATION ::=
17517 -- [formal_parameter_NAME =>] MECHANISM_NAME
17519 -- MECHANISM_NAME ::=
17523 when Pragma_Import_Function
=> Import_Function
: declare
17524 Args
: Args_List
(1 .. 6);
17525 Names
: constant Name_List
(1 .. 6) := (
17528 Name_Parameter_Types
,
17531 Name_Result_Mechanism
);
17533 Internal
: Node_Id
renames Args
(1);
17534 External
: Node_Id
renames Args
(2);
17535 Parameter_Types
: Node_Id
renames Args
(3);
17536 Result_Type
: Node_Id
renames Args
(4);
17537 Mechanism
: Node_Id
renames Args
(5);
17538 Result_Mechanism
: Node_Id
renames Args
(6);
17542 Gather_Associations
(Names
, Args
);
17543 Process_Extended_Import_Export_Subprogram_Pragma
(
17544 Arg_Internal
=> Internal
,
17545 Arg_External
=> External
,
17546 Arg_Parameter_Types
=> Parameter_Types
,
17547 Arg_Result_Type
=> Result_Type
,
17548 Arg_Mechanism
=> Mechanism
,
17549 Arg_Result_Mechanism
=> Result_Mechanism
);
17550 end Import_Function
;
17552 -------------------
17553 -- Import_Object --
17554 -------------------
17556 -- pragma Import_Object (
17557 -- [Internal =>] LOCAL_NAME
17558 -- [, [External =>] EXTERNAL_SYMBOL]
17559 -- [, [Size =>] EXTERNAL_SYMBOL]);
17561 -- EXTERNAL_SYMBOL ::=
17563 -- | static_string_EXPRESSION
17565 when Pragma_Import_Object
=> Import_Object
: declare
17566 Args
: Args_List
(1 .. 3);
17567 Names
: constant Name_List
(1 .. 3) := (
17572 Internal
: Node_Id
renames Args
(1);
17573 External
: Node_Id
renames Args
(2);
17574 Size
: Node_Id
renames Args
(3);
17578 Gather_Associations
(Names
, Args
);
17579 Process_Extended_Import_Export_Object_Pragma
(
17580 Arg_Internal
=> Internal
,
17581 Arg_External
=> External
,
17585 ----------------------
17586 -- Import_Procedure --
17587 ----------------------
17589 -- pragma Import_Procedure (
17590 -- [Internal =>] LOCAL_NAME
17591 -- [, [External =>] EXTERNAL_SYMBOL]
17592 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17593 -- [, [Mechanism =>] MECHANISM]);
17595 -- EXTERNAL_SYMBOL ::=
17597 -- | static_string_EXPRESSION
17599 -- PARAMETER_TYPES ::=
17601 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17603 -- TYPE_DESIGNATOR ::=
17605 -- | subtype_Name ' Access
17609 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17611 -- MECHANISM_ASSOCIATION ::=
17612 -- [formal_parameter_NAME =>] MECHANISM_NAME
17614 -- MECHANISM_NAME ::=
17618 when Pragma_Import_Procedure
=> Import_Procedure
: declare
17619 Args
: Args_List
(1 .. 4);
17620 Names
: constant Name_List
(1 .. 4) := (
17623 Name_Parameter_Types
,
17626 Internal
: Node_Id
renames Args
(1);
17627 External
: Node_Id
renames Args
(2);
17628 Parameter_Types
: Node_Id
renames Args
(3);
17629 Mechanism
: Node_Id
renames Args
(4);
17633 Gather_Associations
(Names
, Args
);
17634 Process_Extended_Import_Export_Subprogram_Pragma
(
17635 Arg_Internal
=> Internal
,
17636 Arg_External
=> External
,
17637 Arg_Parameter_Types
=> Parameter_Types
,
17638 Arg_Mechanism
=> Mechanism
);
17639 end Import_Procedure
;
17641 -----------------------------
17642 -- Import_Valued_Procedure --
17643 -----------------------------
17645 -- pragma Import_Valued_Procedure (
17646 -- [Internal =>] LOCAL_NAME
17647 -- [, [External =>] EXTERNAL_SYMBOL]
17648 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17649 -- [, [Mechanism =>] MECHANISM]);
17651 -- EXTERNAL_SYMBOL ::=
17653 -- | static_string_EXPRESSION
17655 -- PARAMETER_TYPES ::=
17657 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17659 -- TYPE_DESIGNATOR ::=
17661 -- | subtype_Name ' Access
17665 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17667 -- MECHANISM_ASSOCIATION ::=
17668 -- [formal_parameter_NAME =>] MECHANISM_NAME
17670 -- MECHANISM_NAME ::=
17674 when Pragma_Import_Valued_Procedure
=>
17675 Import_Valued_Procedure
: declare
17676 Args
: Args_List
(1 .. 4);
17677 Names
: constant Name_List
(1 .. 4) := (
17680 Name_Parameter_Types
,
17683 Internal
: Node_Id
renames Args
(1);
17684 External
: Node_Id
renames Args
(2);
17685 Parameter_Types
: Node_Id
renames Args
(3);
17686 Mechanism
: Node_Id
renames Args
(4);
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_Mechanism
=> Mechanism
);
17696 end Import_Valued_Procedure
;
17702 -- pragma Independent (LOCAL_NAME);
17704 when Pragma_Independent
=>
17705 Process_Atomic_Independent_Shared_Volatile
;
17707 ----------------------------
17708 -- Independent_Components --
17709 ----------------------------
17711 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17713 when Pragma_Independent_Components
=> Independent_Components
: declare
17721 Check_Ada_83_Warning
;
17723 Check_No_Identifiers
;
17724 Check_Arg_Count
(1);
17725 Check_Arg_Is_Local_Name
(Arg1
);
17726 E_Id
:= Get_Pragma_Arg
(Arg1
);
17728 if Etype
(E_Id
) = Any_Type
then
17732 E
:= Entity
(E_Id
);
17734 -- A record type with a self-referential component of anonymous
17735 -- access type is given an incomplete view in order to handle the
17738 -- type Rec is record
17739 -- Self : access Rec;
17745 -- type Ptr is access Rec;
17746 -- type Rec is record
17750 -- Since the incomplete view is now the initial view of the type,
17751 -- the argument of the pragma will reference the incomplete view,
17752 -- but this view is illegal according to the semantics of the
17755 -- Obtain the full view of an internally-generated incomplete type
17756 -- only. This way an attempt to associate the pragma with a source
17757 -- incomplete type is still caught.
17759 if Ekind
(E
) = E_Incomplete_Type
17760 and then not Comes_From_Source
(E
)
17761 and then Present
(Full_View
(E
))
17763 E
:= Full_View
(E
);
17766 -- A pragma that applies to a Ghost entity becomes Ghost for the
17767 -- purposes of legality checks and removal of ignored Ghost code.
17769 Mark_Ghost_Pragma
(N
, E
);
17771 -- Check duplicate before we chain ourselves
17773 Check_Duplicate_Pragma
(E
);
17775 -- Check appropriate entity
17777 if Rep_Item_Too_Early
(E
, N
)
17779 Rep_Item_Too_Late
(E
, N
)
17784 D
:= Declaration_Node
(E
);
17787 -- The flag is set on the base type, or on the object
17789 if K
= N_Full_Type_Declaration
17790 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17792 Set_Has_Independent_Components
(Base_Type
(E
));
17793 Record_Independence_Check
(N
, Base_Type
(E
));
17795 -- For record type, set all components independent
17797 if Is_Record_Type
(E
) then
17798 C
:= First_Component
(E
);
17799 while Present
(C
) loop
17800 Set_Is_Independent
(C
);
17801 Next_Component
(C
);
17805 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17806 and then Nkind
(D
) = N_Object_Declaration
17807 and then Nkind
(Object_Definition
(D
)) =
17808 N_Constrained_Array_Definition
17810 Set_Has_Independent_Components
(E
);
17811 Record_Independence_Check
(N
, E
);
17814 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17816 end Independent_Components
;
17818 -----------------------
17819 -- Initial_Condition --
17820 -----------------------
17822 -- pragma Initial_Condition (boolean_EXPRESSION);
17824 -- Characteristics:
17826 -- * Analysis - The annotation undergoes initial checks to verify
17827 -- the legal placement and context. Secondary checks preanalyze the
17830 -- Analyze_Initial_Condition_In_Decl_Part
17832 -- * Expansion - The annotation is expanded during the expansion of
17833 -- the package body whose declaration is subject to the annotation
17836 -- Expand_Pragma_Initial_Condition
17838 -- * Template - The annotation utilizes the generic template of the
17839 -- related package declaration.
17841 -- * Globals - Capture of global references must occur after full
17844 -- * Instance - The annotation is instantiated automatically when
17845 -- the related generic package is instantiated.
17847 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17848 Pack_Decl
: Node_Id
;
17849 Pack_Id
: Entity_Id
;
17853 Check_No_Identifiers
;
17854 Check_Arg_Count
(1);
17856 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17858 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17859 N_Package_Declaration
)
17865 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17867 -- A pragma that applies to a Ghost entity becomes Ghost for the
17868 -- purposes of legality checks and removal of ignored Ghost code.
17870 Mark_Ghost_Pragma
(N
, Pack_Id
);
17872 -- Chain the pragma on the contract for further processing by
17873 -- Analyze_Initial_Condition_In_Decl_Part.
17875 Add_Contract_Item
(N
, Pack_Id
);
17877 -- The legality checks of pragmas Abstract_State, Initializes, and
17878 -- Initial_Condition are affected by the SPARK mode in effect. In
17879 -- addition, these three pragmas are subject to an inherent order:
17881 -- 1) Abstract_State
17883 -- 3) Initial_Condition
17885 -- Analyze all these pragmas in the order outlined above
17887 Analyze_If_Present
(Pragma_SPARK_Mode
);
17888 Analyze_If_Present
(Pragma_Abstract_State
);
17889 Analyze_If_Present
(Pragma_Initializes
);
17890 end Initial_Condition
;
17892 ------------------------
17893 -- Initialize_Scalars --
17894 ------------------------
17896 -- pragma Initialize_Scalars
17897 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17899 -- TYPE_VALUE_PAIR ::=
17900 -- SCALAR_TYPE => static_EXPRESSION
17906 -- | Long_Long_Flat
17916 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
17917 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
17918 -- This collection holds the individual pairs which specify the
17919 -- invalid values of their respective scalar types.
17921 procedure Analyze_Float_Value
17922 (Scal_Typ
: Float_Scalar_Id
;
17923 Val_Expr
: Node_Id
);
17924 -- Analyze a type value pair associated with float type Scal_Typ
17925 -- and expression Val_Expr.
17927 procedure Analyze_Integer_Value
17928 (Scal_Typ
: Integer_Scalar_Id
;
17929 Val_Expr
: Node_Id
);
17930 -- Analyze a type value pair associated with integer type Scal_Typ
17931 -- and expression Val_Expr.
17933 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
17934 -- Analyze type value pair Pair
17936 -------------------------
17937 -- Analyze_Float_Value --
17938 -------------------------
17940 procedure Analyze_Float_Value
17941 (Scal_Typ
: Float_Scalar_Id
;
17942 Val_Expr
: Node_Id
)
17945 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
17947 if Is_OK_Static_Expression
(Val_Expr
) then
17948 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
17951 Error_Msg_Name_1
:= Scal_Typ
;
17952 Error_Msg_N
("value for type % must be static", Val_Expr
);
17954 end Analyze_Float_Value
;
17956 ---------------------------
17957 -- Analyze_Integer_Value --
17958 ---------------------------
17960 procedure Analyze_Integer_Value
17961 (Scal_Typ
: Integer_Scalar_Id
;
17962 Val_Expr
: Node_Id
)
17965 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
17967 if Is_OK_Static_Expression
(Val_Expr
) then
17968 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
17971 Error_Msg_Name_1
:= Scal_Typ
;
17972 Error_Msg_N
("value for type % must be static", Val_Expr
);
17974 end Analyze_Integer_Value
;
17976 -----------------------------
17977 -- Analyze_Type_Value_Pair --
17978 -----------------------------
17980 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
17981 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
17982 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
17983 Prev_Pair
: Node_Id
;
17986 if Scal_Typ
in Scalar_Id
then
17987 Prev_Pair
:= Seen
(Scal_Typ
);
17989 -- Prevent multiple attempts to set a value for a scalar
17992 if Present
(Prev_Pair
) then
17993 Error_Msg_Name_1
:= Scal_Typ
;
17995 ("cannot specify multiple invalid values for type %",
17998 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
17999 Error_Msg_N
("previous value set #", Pair
);
18001 -- Ignore the effects of the pair, but do not halt the
18002 -- analysis of the pragma altogether.
18006 -- Otherwise capture the first pair for this scalar type
18009 Seen
(Scal_Typ
) := Pair
;
18012 if Scal_Typ
in Float_Scalar_Id
then
18013 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18015 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18016 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18019 -- Otherwise the scalar family is illegal
18022 Error_Msg_Name_1
:= Pname
;
18024 ("argument of pragma % must denote valid scalar family",
18027 end Analyze_Type_Value_Pair
;
18031 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18034 -- Start of processing for Do_Initialize_Scalars
18038 Check_Valid_Configuration_Pragma
;
18039 Check_Restriction
(No_Initialize_Scalars
, N
);
18041 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18044 if Restriction_Active
(No_Initialize_Scalars
) then
18047 -- Initialize_Scalars creates false positives in CodePeer, and
18048 -- incorrect negative results in GNATprove mode, so ignore this
18049 -- pragma in these modes.
18051 elsif CodePeer_Mode
or GNATprove_Mode
then
18054 -- Otherwise analyze the pragma
18057 if Present
(Pairs
) then
18059 -- Install Standard in order to provide access to primitive
18060 -- types in case the expressions contain attributes such as
18063 Push_Scope
(Standard_Standard
);
18065 Pair
:= First
(Pairs
);
18066 while Present
(Pair
) loop
18067 Analyze_Type_Value_Pair
(Pair
);
18076 Init_Or_Norm_Scalars
:= True;
18077 Initialize_Scalars
:= True;
18079 end Do_Initialize_Scalars
;
18085 -- pragma Initializes (INITIALIZATION_LIST);
18087 -- INITIALIZATION_LIST ::=
18089 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18091 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18096 -- | (INPUT {, INPUT})
18100 -- Characteristics:
18102 -- * Analysis - The annotation undergoes initial checks to verify
18103 -- the legal placement and context. Secondary checks preanalyze the
18106 -- Analyze_Initializes_In_Decl_Part
18108 -- * Expansion - None.
18110 -- * Template - The annotation utilizes the generic template of the
18111 -- related package declaration.
18113 -- * Globals - Capture of global references must occur after full
18116 -- * Instance - The annotation is instantiated automatically when
18117 -- the related generic package is instantiated.
18119 when Pragma_Initializes
=> Initializes
: declare
18120 Pack_Decl
: Node_Id
;
18121 Pack_Id
: Entity_Id
;
18125 Check_No_Identifiers
;
18126 Check_Arg_Count
(1);
18128 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18130 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
18131 N_Package_Declaration
)
18137 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18139 -- A pragma that applies to a Ghost entity becomes Ghost for the
18140 -- purposes of legality checks and removal of ignored Ghost code.
18142 Mark_Ghost_Pragma
(N
, Pack_Id
);
18143 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18145 -- Chain the pragma on the contract for further processing by
18146 -- Analyze_Initializes_In_Decl_Part.
18148 Add_Contract_Item
(N
, Pack_Id
);
18150 -- The legality checks of pragmas Abstract_State, Initializes, and
18151 -- Initial_Condition are affected by the SPARK mode in effect. In
18152 -- addition, these three pragmas are subject to an inherent order:
18154 -- 1) Abstract_State
18156 -- 3) Initial_Condition
18158 -- Analyze all these pragmas in the order outlined above
18160 Analyze_If_Present
(Pragma_SPARK_Mode
);
18161 Analyze_If_Present
(Pragma_Abstract_State
);
18162 Analyze_If_Present
(Pragma_Initial_Condition
);
18169 -- pragma Inline ( NAME {, NAME} );
18171 when Pragma_Inline
=>
18173 -- Pragma always active unless in GNATprove mode. It is disabled
18174 -- in GNATprove mode because frontend inlining is applied
18175 -- independently of pragmas Inline and Inline_Always for
18176 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18179 if not GNATprove_Mode
then
18181 -- Inline status is Enabled if option -gnatn is specified.
18182 -- However this status determines only the value of the
18183 -- Is_Inlined flag on the subprogram and does not prevent
18184 -- the pragma itself from being recorded for later use,
18185 -- in particular for a later modification of Is_Inlined
18186 -- independently of the -gnatn option.
18188 -- In other words, if -gnatn is specified for a unit, then
18189 -- all Inline pragmas processed for the compilation of this
18190 -- unit, including those in the spec of other units, are
18191 -- activated, so subprograms will be inlined across units.
18193 -- If -gnatn is not specified, no Inline pragma is activated
18194 -- here, which means that subprograms will not be inlined
18195 -- across units. The Is_Inlined flag will nevertheless be
18196 -- set later when bodies are analyzed, so subprograms will
18197 -- be inlined within the unit.
18199 if Inline_Active
then
18200 Process_Inline
(Enabled
);
18202 Process_Inline
(Disabled
);
18206 -------------------
18207 -- Inline_Always --
18208 -------------------
18210 -- pragma Inline_Always ( NAME {, NAME} );
18212 when Pragma_Inline_Always
=>
18215 -- Pragma always active unless in CodePeer mode or GNATprove
18216 -- mode. It is disabled in CodePeer mode because inlining is
18217 -- not helpful, and enabling it caused walk order issues. It
18218 -- is disabled in GNATprove mode because frontend inlining is
18219 -- applied independently of pragmas Inline and Inline_Always for
18220 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18223 if not CodePeer_Mode
and not GNATprove_Mode
then
18224 Process_Inline
(Enabled
);
18227 --------------------
18228 -- Inline_Generic --
18229 --------------------
18231 -- pragma Inline_Generic (NAME {, NAME});
18233 when Pragma_Inline_Generic
=>
18235 Process_Generic_List
;
18237 ----------------------
18238 -- Inspection_Point --
18239 ----------------------
18241 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18243 when Pragma_Inspection_Point
=> Inspection_Point
: declare
18250 if Arg_Count
> 0 then
18253 Exp
:= Get_Pragma_Arg
(Arg
);
18256 if not Is_Entity_Name
(Exp
)
18257 or else not Is_Object
(Entity
(Exp
))
18259 Error_Pragma_Arg
("object name required", Arg
);
18263 exit when No
(Arg
);
18266 end Inspection_Point
;
18272 -- pragma Interface (
18273 -- [ Convention =>] convention_IDENTIFIER,
18274 -- [ Entity =>] LOCAL_NAME
18275 -- [, [External_Name =>] static_string_EXPRESSION ]
18276 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18278 when Pragma_Interface
=>
18283 Name_External_Name
,
18285 Check_At_Least_N_Arguments
(2);
18286 Check_At_Most_N_Arguments
(4);
18287 Process_Import_Or_Interface
;
18289 -- In Ada 2005, the permission to use Interface (a reserved word)
18290 -- as a pragma name is considered an obsolescent feature, and this
18291 -- pragma was already obsolescent in Ada 95.
18293 if Ada_Version
>= Ada_95
then
18295 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
18297 if Warn_On_Obsolescent_Feature
then
18299 ("pragma Interface is an obsolescent feature?j?", N
);
18301 ("|use pragma Import instead?j?", N
);
18305 --------------------
18306 -- Interface_Name --
18307 --------------------
18309 -- pragma Interface_Name (
18310 -- [ Entity =>] LOCAL_NAME
18311 -- [,[External_Name =>] static_string_EXPRESSION ]
18312 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18314 when Pragma_Interface_Name
=> Interface_Name
: declare
18316 Def_Id
: Entity_Id
;
18317 Hom_Id
: Entity_Id
;
18323 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
18324 Check_At_Least_N_Arguments
(2);
18325 Check_At_Most_N_Arguments
(3);
18326 Id
:= Get_Pragma_Arg
(Arg1
);
18329 -- This is obsolete from Ada 95 on, but it is an implementation
18330 -- defined pragma, so we do not consider that it violates the
18331 -- restriction (No_Obsolescent_Features).
18333 if Ada_Version
>= Ada_95
then
18334 if Warn_On_Obsolescent_Feature
then
18336 ("pragma Interface_Name is an obsolescent feature?j?", N
);
18338 ("|use pragma Import instead?j?", N
);
18342 if not Is_Entity_Name
(Id
) then
18344 ("first argument for pragma% must be entity name", Arg1
);
18345 elsif Etype
(Id
) = Any_Type
then
18348 Def_Id
:= Entity
(Id
);
18351 -- Special DEC-compatible processing for the object case, forces
18352 -- object to be imported.
18354 if Ekind
(Def_Id
) = E_Variable
then
18355 Kill_Size_Check_Code
(Def_Id
);
18356 Note_Possible_Modification
(Id
, Sure
=> False);
18358 -- Initialization is not allowed for imported variable
18360 if Present
(Expression
(Parent
(Def_Id
)))
18361 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
18363 Error_Msg_Sloc
:= Sloc
(Def_Id
);
18365 ("no initialization allowed for declaration of& #",
18369 -- For compatibility, support VADS usage of providing both
18370 -- pragmas Interface and Interface_Name to obtain the effect
18371 -- of a single Import pragma.
18373 if Is_Imported
(Def_Id
)
18374 and then Present
(First_Rep_Item
(Def_Id
))
18375 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
18376 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
18381 Set_Imported
(Def_Id
);
18384 Set_Is_Public
(Def_Id
);
18385 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18388 -- Otherwise must be subprogram
18390 elsif not Is_Subprogram
(Def_Id
) then
18392 ("argument of pragma% is not subprogram", Arg1
);
18395 Check_At_Most_N_Arguments
(3);
18399 -- Loop through homonyms
18402 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
18404 if Is_Imported
(Def_Id
) then
18405 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18409 exit when From_Aspect_Specification
(N
);
18410 Hom_Id
:= Homonym
(Hom_Id
);
18412 exit when No
(Hom_Id
)
18413 or else Scope
(Hom_Id
) /= Current_Scope
;
18418 ("argument of pragma% is not imported subprogram",
18422 end Interface_Name
;
18424 -----------------------
18425 -- Interrupt_Handler --
18426 -----------------------
18428 -- pragma Interrupt_Handler (handler_NAME);
18430 when Pragma_Interrupt_Handler
=>
18431 Check_Ada_83_Warning
;
18432 Check_Arg_Count
(1);
18433 Check_No_Identifiers
;
18435 if No_Run_Time_Mode
then
18436 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
18438 Check_Interrupt_Or_Attach_Handler
;
18439 Process_Interrupt_Or_Attach_Handler
;
18442 ------------------------
18443 -- Interrupt_Priority --
18444 ------------------------
18446 -- pragma Interrupt_Priority [(EXPRESSION)];
18448 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
18449 P
: constant Node_Id
:= Parent
(N
);
18454 Check_Ada_83_Warning
;
18456 if Arg_Count
/= 0 then
18457 Arg
:= Get_Pragma_Arg
(Arg1
);
18458 Check_Arg_Count
(1);
18459 Check_No_Identifiers
;
18461 -- The expression must be analyzed in the special manner
18462 -- described in "Handling of Default and Per-Object
18463 -- Expressions" in sem.ads.
18465 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
18468 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
18473 Ent
:= Defining_Identifier
(Parent
(P
));
18475 -- Check duplicate pragma before we chain the pragma in the Rep
18476 -- Item chain of Ent.
18478 Check_Duplicate_Pragma
(Ent
);
18479 Record_Rep_Item
(Ent
, N
);
18481 -- Check the No_Task_At_Interrupt_Priority restriction
18483 if Nkind
(P
) = N_Task_Definition
then
18484 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
18487 end Interrupt_Priority
;
18489 ---------------------
18490 -- Interrupt_State --
18491 ---------------------
18493 -- pragma Interrupt_State (
18494 -- [Name =>] INTERRUPT_ID,
18495 -- [State =>] INTERRUPT_STATE);
18497 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18498 -- INTERRUPT_STATE => System | Runtime | User
18500 -- Note: if the interrupt id is given as an identifier, then it must
18501 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18502 -- given as a static integer expression which must be in the range of
18503 -- Ada.Interrupts.Interrupt_ID.
18505 when Pragma_Interrupt_State
=> Interrupt_State
: declare
18506 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
18507 -- This is the entity Ada.Interrupts.Interrupt_ID;
18509 State_Type
: Character;
18510 -- Set to 's'/'r'/'u' for System/Runtime/User
18513 -- Index to entry in Interrupt_States table
18516 -- Value of interrupt
18518 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18519 -- The first argument to the pragma
18521 Int_Ent
: Entity_Id
;
18522 -- Interrupt entity in Ada.Interrupts.Names
18526 Check_Arg_Order
((Name_Name
, Name_State
));
18527 Check_Arg_Count
(2);
18529 Check_Optional_Identifier
(Arg1
, Name_Name
);
18530 Check_Optional_Identifier
(Arg2
, Name_State
);
18531 Check_Arg_Is_Identifier
(Arg2
);
18533 -- First argument is identifier
18535 if Nkind
(Arg1X
) = N_Identifier
then
18537 -- Search list of names in Ada.Interrupts.Names
18539 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
18541 if No
(Int_Ent
) then
18542 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
18544 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
18545 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
18549 Next_Entity
(Int_Ent
);
18552 -- First argument is not an identifier, so it must be a static
18553 -- expression of type Ada.Interrupts.Interrupt_ID.
18556 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
18557 Int_Val
:= Expr_Value
(Arg1X
);
18559 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
18561 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
18564 ("value not in range of type "
18565 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
18571 case Chars
(Get_Pragma_Arg
(Arg2
)) is
18572 when Name_Runtime
=> State_Type
:= 'r';
18573 when Name_System
=> State_Type
:= 's';
18574 when Name_User
=> State_Type
:= 'u';
18577 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
18580 -- Check if entry is already stored
18582 IST_Num
:= Interrupt_States
.First
;
18584 -- If entry not found, add it
18586 if IST_Num
> Interrupt_States
.Last
then
18587 Interrupt_States
.Append
18588 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
18589 Interrupt_State
=> State_Type
,
18590 Pragma_Loc
=> Loc
));
18593 -- Case of entry for the same entry
18595 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
18598 -- If state matches, done, no need to make redundant entry
18601 State_Type
= Interrupt_States
.Table
(IST_Num
).
18604 -- Otherwise if state does not match, error
18607 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
18609 ("state conflicts with that given #", Arg2
);
18613 IST_Num
:= IST_Num
+ 1;
18615 end Interrupt_State
;
18621 -- pragma Invariant
18622 -- ([Entity =>] type_LOCAL_NAME,
18623 -- [Check =>] EXPRESSION
18624 -- [,[Message =>] String_Expression]);
18626 when Pragma_Invariant
=> Invariant
: declare
18633 Check_At_Least_N_Arguments
(2);
18634 Check_At_Most_N_Arguments
(3);
18635 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18636 Check_Optional_Identifier
(Arg2
, Name_Check
);
18638 if Arg_Count
= 3 then
18639 Check_Optional_Identifier
(Arg3
, Name_Message
);
18640 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
18643 Check_Arg_Is_Local_Name
(Arg1
);
18645 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
18646 Find_Type
(Typ_Arg
);
18647 Typ
:= Entity
(Typ_Arg
);
18649 -- Nothing to do of the related type is erroneous in some way
18651 if Typ
= Any_Type
then
18654 -- AI12-0041: Invariants are allowed in interface types
18656 elsif Is_Interface
(Typ
) then
18659 -- An invariant must apply to a private type, or appear in the
18660 -- private part of a package spec and apply to a completion.
18661 -- a class-wide invariant can only appear on a private declaration
18662 -- or private extension, not a completion.
18664 -- A [class-wide] invariant may be associated a [limited] private
18665 -- type or a private extension.
18667 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
18669 E_Record_Type_With_Private
)
18673 -- A non-class-wide invariant may be associated with the full view
18674 -- of a [limited] private type or a private extension.
18676 elsif Has_Private_Declaration
(Typ
)
18677 and then not Class_Present
(N
)
18681 -- A class-wide invariant may appear on the partial view only
18683 elsif Class_Present
(N
) then
18685 ("pragma % only allowed for private type", Arg1
);
18688 -- A regular invariant may appear on both views
18692 ("pragma % only allowed for private type or corresponding "
18693 & "full view", Arg1
);
18697 -- An invariant associated with an abstract type (this includes
18698 -- interfaces) must be class-wide.
18700 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18702 ("pragma % not allowed for abstract type", Arg1
);
18706 -- A pragma that applies to a Ghost entity becomes Ghost for the
18707 -- purposes of legality checks and removal of ignored Ghost code.
18709 Mark_Ghost_Pragma
(N
, Typ
);
18711 -- The pragma defines a type-specific invariant, the type is said
18712 -- to have invariants of its "own".
18714 Set_Has_Own_Invariants
(Typ
);
18716 -- If the invariant is class-wide, then it can be inherited by
18717 -- derived or interface implementing types. The type is said to
18718 -- have "inheritable" invariants.
18720 if Class_Present
(N
) then
18721 Set_Has_Inheritable_Invariants
(Typ
);
18724 -- Chain the pragma on to the rep item chain, for processing when
18725 -- the type is frozen.
18727 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18729 -- Create the declaration of the invariant procedure that will
18730 -- verify the invariant at run time. Interfaces are treated as the
18731 -- partial view of a private type in order to achieve uniformity
18732 -- with the general case. As a result, an interface receives only
18733 -- a "partial" invariant procedure, which is never called.
18735 Build_Invariant_Procedure_Declaration
18737 Partial_Invariant
=> Is_Interface
(Typ
));
18744 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18746 when Pragma_Keep_Names
=> Keep_Names
: declare
18751 Check_Arg_Count
(1);
18752 Check_Optional_Identifier
(Arg1
, Name_On
);
18753 Check_Arg_Is_Local_Name
(Arg1
);
18755 Arg
:= Get_Pragma_Arg
(Arg1
);
18758 if Etype
(Arg
) = Any_Type
then
18762 if not Is_Entity_Name
(Arg
)
18763 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18766 ("pragma% requires a local enumeration type", Arg1
);
18769 Set_Discard_Names
(Entity
(Arg
), False);
18776 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18778 when Pragma_License
=>
18781 -- Do not analyze pragma any further in CodePeer mode, to avoid
18782 -- extraneous errors in this implementation-dependent pragma,
18783 -- which has a different profile on other compilers.
18785 if CodePeer_Mode
then
18789 Check_Arg_Count
(1);
18790 Check_No_Identifiers
;
18791 Check_Valid_Configuration_Pragma
;
18792 Check_Arg_Is_Identifier
(Arg1
);
18795 Sind
: constant Source_File_Index
:=
18796 Source_Index
(Current_Sem_Unit
);
18799 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18801 Set_License
(Sind
, GPL
);
18803 when Name_Modified_GPL
=>
18804 Set_License
(Sind
, Modified_GPL
);
18806 when Name_Restricted
=>
18807 Set_License
(Sind
, Restricted
);
18809 when Name_Unrestricted
=>
18810 Set_License
(Sind
, Unrestricted
);
18813 Error_Pragma_Arg
("invalid license name", Arg1
);
18821 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18823 when Pragma_Link_With
=> Link_With
: declare
18829 if Operating_Mode
= Generate_Code
18830 and then In_Extended_Main_Source_Unit
(N
)
18832 Check_At_Least_N_Arguments
(1);
18833 Check_No_Identifiers
;
18834 Check_Is_In_Decl_Part_Or_Package_Spec
;
18835 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18839 while Present
(Arg
) loop
18840 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18842 -- Store argument, converting sequences of spaces to a
18843 -- single null character (this is one of the differences
18844 -- in processing between Link_With and Linker_Options).
18846 Arg_Store
: declare
18847 C
: constant Char_Code
:= Get_Char_Code
(' ');
18848 S
: constant String_Id
:=
18849 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18850 L
: constant Nat
:= String_Length
(S
);
18853 procedure Skip_Spaces
;
18854 -- Advance F past any spaces
18860 procedure Skip_Spaces
is
18862 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18867 -- Start of processing for Arg_Store
18870 Skip_Spaces
; -- skip leading spaces
18872 -- Loop through characters, changing any embedded
18873 -- sequence of spaces to a single null character (this
18874 -- is how Link_With/Linker_Options differ)
18877 if Get_String_Char
(S
, F
) = C
then
18880 Store_String_Char
(ASCII
.NUL
);
18883 Store_String_Char
(Get_String_Char
(S
, F
));
18891 if Present
(Arg
) then
18892 Store_String_Char
(ASCII
.NUL
);
18896 Store_Linker_Option_String
(End_String
);
18904 -- pragma Linker_Alias (
18905 -- [Entity =>] LOCAL_NAME
18906 -- [Target =>] static_string_EXPRESSION);
18908 when Pragma_Linker_Alias
=>
18910 Check_Arg_Order
((Name_Entity
, Name_Target
));
18911 Check_Arg_Count
(2);
18912 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18913 Check_Optional_Identifier
(Arg2
, Name_Target
);
18914 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18915 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18917 -- The only processing required is to link this item on to the
18918 -- list of rep items for the given entity. This is accomplished
18919 -- by the call to Rep_Item_Too_Late (when no error is detected
18920 -- and False is returned).
18922 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
18925 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18928 ------------------------
18929 -- Linker_Constructor --
18930 ------------------------
18932 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18934 -- Code is shared with Linker_Destructor
18936 -----------------------
18937 -- Linker_Destructor --
18938 -----------------------
18940 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18942 when Pragma_Linker_Constructor
18943 | Pragma_Linker_Destructor
18945 Linker_Constructor
: declare
18951 Check_Arg_Count
(1);
18952 Check_No_Identifiers
;
18953 Check_Arg_Is_Local_Name
(Arg1
);
18954 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
18956 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
18958 if not Is_Library_Level_Entity
(Proc
) then
18960 ("argument for pragma% must be library level entity", Arg1
);
18963 -- The only processing required is to link this item on to the
18964 -- list of rep items for the given entity. This is accomplished
18965 -- by the call to Rep_Item_Too_Late (when no error is detected
18966 -- and False is returned).
18968 if Rep_Item_Too_Late
(Proc
, N
) then
18971 Set_Has_Gigi_Rep_Item
(Proc
);
18973 end Linker_Constructor
;
18975 --------------------
18976 -- Linker_Options --
18977 --------------------
18979 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18981 when Pragma_Linker_Options
=> Linker_Options
: declare
18985 Check_Ada_83_Warning
;
18986 Check_No_Identifiers
;
18987 Check_Arg_Count
(1);
18988 Check_Is_In_Decl_Part_Or_Package_Spec
;
18989 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18990 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
18993 while Present
(Arg
) loop
18994 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18995 Store_String_Char
(ASCII
.NUL
);
18997 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19001 if Operating_Mode
= Generate_Code
19002 and then In_Extended_Main_Source_Unit
(N
)
19004 Store_Linker_Option_String
(End_String
);
19006 end Linker_Options
;
19008 --------------------
19009 -- Linker_Section --
19010 --------------------
19012 -- pragma Linker_Section (
19013 -- [Entity =>] LOCAL_NAME
19014 -- [Section =>] static_string_EXPRESSION);
19016 when Pragma_Linker_Section
=> Linker_Section
: declare
19021 Ghost_Error_Posted
: Boolean := False;
19022 -- Flag set when an error concerning the illegal mix of Ghost and
19023 -- non-Ghost subprograms is emitted.
19025 Ghost_Id
: Entity_Id
:= Empty
;
19026 -- The entity of the first Ghost subprogram encountered while
19027 -- processing the arguments of the pragma.
19031 Check_Arg_Order
((Name_Entity
, Name_Section
));
19032 Check_Arg_Count
(2);
19033 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19034 Check_Optional_Identifier
(Arg2
, Name_Section
);
19035 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19036 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19038 -- Check kind of entity
19040 Arg
:= Get_Pragma_Arg
(Arg1
);
19041 Ent
:= Entity
(Arg
);
19043 case Ekind
(Ent
) is
19045 -- Objects (constants and variables) and types. For these cases
19046 -- all we need to do is to set the Linker_Section_pragma field,
19047 -- checking that we do not have a duplicate.
19053 LPE
:= Linker_Section_Pragma
(Ent
);
19055 if Present
(LPE
) then
19056 Error_Msg_Sloc
:= Sloc
(LPE
);
19058 ("Linker_Section already specified for &#", Arg1
, Ent
);
19061 Set_Linker_Section_Pragma
(Ent
, N
);
19063 -- A pragma that applies to a Ghost entity becomes Ghost for
19064 -- the purposes of legality checks and removal of ignored
19067 Mark_Ghost_Pragma
(N
, Ent
);
19071 when Subprogram_Kind
=>
19073 -- Aspect case, entity already set
19075 if From_Aspect_Specification
(N
) then
19076 Set_Linker_Section_Pragma
19077 (Entity
(Corresponding_Aspect
(N
)), N
);
19079 -- Pragma case, we must climb the homonym chain, but skip
19080 -- any for which the linker section is already set.
19084 if No
(Linker_Section_Pragma
(Ent
)) then
19085 Set_Linker_Section_Pragma
(Ent
, N
);
19087 -- A pragma that applies to a Ghost entity becomes
19088 -- Ghost for the purposes of legality checks and
19089 -- removal of ignored Ghost code.
19091 Mark_Ghost_Pragma
(N
, Ent
);
19093 -- Capture the entity of the first Ghost subprogram
19094 -- being processed for error detection purposes.
19096 if Is_Ghost_Entity
(Ent
) then
19097 if No
(Ghost_Id
) then
19101 -- Otherwise the subprogram is non-Ghost. It is
19102 -- illegal to mix references to Ghost and non-Ghost
19103 -- entities (SPARK RM 6.9).
19105 elsif Present
(Ghost_Id
)
19106 and then not Ghost_Error_Posted
19108 Ghost_Error_Posted
:= True;
19110 Error_Msg_Name_1
:= Pname
;
19112 ("pragma % cannot mention ghost and "
19113 & "non-ghost subprograms", N
);
19115 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19117 ("\& # declared as ghost", N
, Ghost_Id
);
19119 Error_Msg_Sloc
:= Sloc
(Ent
);
19121 ("\& # declared as non-ghost", N
, Ent
);
19125 Ent
:= Homonym
(Ent
);
19127 or else Scope
(Ent
) /= Current_Scope
;
19131 -- All other cases are illegal
19135 ("pragma% applies only to objects, subprograms, and types",
19138 end Linker_Section
;
19144 -- pragma List (On | Off)
19146 -- There is nothing to do here, since we did all the processing for
19147 -- this pragma in Par.Prag (so that it works properly even in syntax
19150 when Pragma_List
=>
19157 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19159 when Pragma_Lock_Free
=> Lock_Free
: declare
19160 P
: constant Node_Id
:= Parent
(N
);
19166 Check_No_Identifiers
;
19167 Check_At_Most_N_Arguments
(1);
19169 -- Protected definition case
19171 if Nkind
(P
) = N_Protected_Definition
then
19172 Ent
:= Defining_Identifier
(Parent
(P
));
19176 if Arg_Count
= 1 then
19177 Arg
:= Get_Pragma_Arg
(Arg1
);
19178 Val
:= Is_True
(Static_Boolean
(Arg
));
19180 -- No arguments (expression is considered to be True)
19186 -- Check duplicate pragma before we chain the pragma in the Rep
19187 -- Item chain of Ent.
19189 Check_Duplicate_Pragma
(Ent
);
19190 Record_Rep_Item
(Ent
, N
);
19191 Set_Uses_Lock_Free
(Ent
, Val
);
19193 -- Anything else is incorrect placement
19200 --------------------
19201 -- Locking_Policy --
19202 --------------------
19204 -- pragma Locking_Policy (policy_IDENTIFIER);
19206 when Pragma_Locking_Policy
=> declare
19207 subtype LP_Range
is Name_Id
19208 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
19213 Check_Ada_83_Warning
;
19214 Check_Arg_Count
(1);
19215 Check_No_Identifiers
;
19216 Check_Arg_Is_Locking_Policy
(Arg1
);
19217 Check_Valid_Configuration_Pragma
;
19218 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19221 when Name_Ceiling_Locking
=> LP
:= 'C';
19222 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
19223 when Name_Inheritance_Locking
=> LP
:= 'I';
19226 if Locking_Policy
/= ' '
19227 and then Locking_Policy
/= LP
19229 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19230 Error_Pragma
("locking policy incompatible with policy#");
19232 -- Set new policy, but always preserve System_Location since we
19233 -- like the error message with the run time name.
19236 Locking_Policy
:= LP
;
19238 if Locking_Policy_Sloc
/= System_Location
then
19239 Locking_Policy_Sloc
:= Loc
;
19244 -------------------
19245 -- Loop_Optimize --
19246 -------------------
19248 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19250 -- OPTIMIZATION_HINT ::=
19251 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19253 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
19258 Check_At_Least_N_Arguments
(1);
19259 Check_No_Identifiers
;
19261 Hint
:= First
(Pragma_Argument_Associations
(N
));
19262 while Present
(Hint
) loop
19263 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
19271 Check_Loop_Pragma_Placement
;
19278 -- pragma Loop_Variant
19279 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19281 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19283 -- CHANGE_DIRECTION ::= Increases | Decreases
19285 when Pragma_Loop_Variant
=> Loop_Variant
: declare
19290 Check_At_Least_N_Arguments
(1);
19291 Check_Loop_Pragma_Placement
;
19293 -- Process all increasing / decreasing expressions
19295 Variant
:= First
(Pragma_Argument_Associations
(N
));
19296 while Present
(Variant
) loop
19297 if Chars
(Variant
) = No_Name
then
19298 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
19300 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
19304 Name
: String := Get_Name_String
(Chars
(Variant
));
19307 -- It is a common mistake to write "Increasing" for
19308 -- "Increases" or "Decreasing" for "Decreases". Recognize
19309 -- specially names starting with "incr" or "decr" to
19310 -- suggest the corresponding name.
19312 System
.Case_Util
.To_Lower
(Name
);
19314 if Name
'Length >= 4
19315 and then Name
(1 .. 4) = "incr"
19317 Error_Pragma_Arg_Ident
19318 ("expect name `Increases`", Variant
);
19320 elsif Name
'Length >= 4
19321 and then Name
(1 .. 4) = "decr"
19323 Error_Pragma_Arg_Ident
19324 ("expect name `Decreases`", Variant
);
19327 Error_Pragma_Arg_Ident
19328 ("expect name `Increases` or `Decreases`", Variant
);
19333 Preanalyze_Assert_Expression
19334 (Expression
(Variant
), Any_Discrete
);
19340 -----------------------
19341 -- Machine_Attribute --
19342 -----------------------
19344 -- pragma Machine_Attribute (
19345 -- [Entity =>] LOCAL_NAME,
19346 -- [Attribute_Name =>] static_string_EXPRESSION
19347 -- [, [Info =>] static_EXPRESSION] );
19349 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
19350 Def_Id
: Entity_Id
;
19354 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
19356 if Arg_Count
= 3 then
19357 Check_Optional_Identifier
(Arg3
, Name_Info
);
19358 Check_Arg_Is_OK_Static_Expression
(Arg3
);
19360 Check_Arg_Count
(2);
19363 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19364 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
19365 Check_Arg_Is_Local_Name
(Arg1
);
19366 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19367 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
19369 if Is_Access_Type
(Def_Id
) then
19370 Def_Id
:= Designated_Type
(Def_Id
);
19373 if Rep_Item_Too_Early
(Def_Id
, N
) then
19377 Def_Id
:= Underlying_Type
(Def_Id
);
19379 -- The only processing required is to link this item on to the
19380 -- list of rep items for the given entity. This is accomplished
19381 -- by the call to Rep_Item_Too_Late (when no error is detected
19382 -- and False is returned).
19384 if Rep_Item_Too_Late
(Def_Id
, N
) then
19387 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19389 end Machine_Attribute
;
19396 -- (MAIN_OPTION [, MAIN_OPTION]);
19399 -- [STACK_SIZE =>] static_integer_EXPRESSION
19400 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19401 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19403 when Pragma_Main
=> Main
: declare
19404 Args
: Args_List
(1 .. 3);
19405 Names
: constant Name_List
(1 .. 3) := (
19407 Name_Task_Stack_Size_Default
,
19408 Name_Time_Slicing_Enabled
);
19414 Gather_Associations
(Names
, Args
);
19416 for J
in 1 .. 2 loop
19417 if Present
(Args
(J
)) then
19418 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19422 if Present
(Args
(3)) then
19423 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
19427 while Present
(Nod
) loop
19428 if Nkind
(Nod
) = N_Pragma
19429 and then Pragma_Name
(Nod
) = Name_Main
19431 Error_Msg_Name_1
:= Pname
;
19432 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19443 -- pragma Main_Storage
19444 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19446 -- MAIN_STORAGE_OPTION ::=
19447 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19448 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19450 when Pragma_Main_Storage
=> Main_Storage
: declare
19451 Args
: Args_List
(1 .. 2);
19452 Names
: constant Name_List
(1 .. 2) := (
19453 Name_Working_Storage
,
19460 Gather_Associations
(Names
, Args
);
19462 for J
in 1 .. 2 loop
19463 if Present
(Args
(J
)) then
19464 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19468 Check_In_Main_Program
;
19471 while Present
(Nod
) loop
19472 if Nkind
(Nod
) = N_Pragma
19473 and then Pragma_Name
(Nod
) = Name_Main_Storage
19475 Error_Msg_Name_1
:= Pname
;
19476 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19483 ----------------------
19484 -- Max_Queue_Length --
19485 ----------------------
19487 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
19489 -- This processing is shared by Pragma_Max_Entry_Queue_Depth
19491 when Pragma_Max_Queue_Length
19492 | Pragma_Max_Entry_Queue_Depth
19494 Max_Queue_Length
: declare
19496 Entry_Decl
: Node_Id
;
19497 Entry_Id
: Entity_Id
;
19501 if Prag_Id
= Pragma_Max_Queue_Length
then
19505 Check_Arg_Count
(1);
19508 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
19510 -- Entry declaration
19512 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
19514 -- Entry illegally within a task
19516 if Nkind
(Parent
(N
)) = N_Task_Definition
then
19517 Error_Pragma
("pragma % cannot apply to task entries");
19521 Entry_Id
:= Defining_Entity
(Entry_Decl
);
19523 -- Otherwise the pragma is associated with an illegal construct
19526 Error_Pragma
("pragma % must apply to a protected entry");
19530 -- Mark the pragma as Ghost if the related subprogram is also
19531 -- Ghost. This also ensures that any expansion performed further
19532 -- below will produce Ghost nodes.
19534 Mark_Ghost_Pragma
(N
, Entry_Id
);
19536 -- Analyze the Integer expression
19538 Arg
:= Get_Pragma_Arg
(Arg1
);
19539 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
19541 Val
:= Expr_Value
(Arg
);
19545 ("argument for pragma% must be positive", Arg1
);
19547 elsif not UI_Is_In_Int_Range
(Val
) then
19549 ("argument for pragma% out of range of Integer", Arg1
);
19553 -- Manually substitute the expression value of the pragma argument
19554 -- if it's not an integer literal because this is not taken care
19555 -- of automatically elsewhere.
19557 if Nkind
(Arg
) /= N_Integer_Literal
then
19558 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
19559 Set_Etype
(Arg
, Etype
(Original_Node
(Arg
)));
19562 Record_Rep_Item
(Entry_Id
, N
);
19563 end Max_Queue_Length
;
19569 -- pragma Memory_Size (NUMERIC_LITERAL)
19571 when Pragma_Memory_Size
=>
19574 -- Memory size is simply ignored
19576 Check_No_Identifiers
;
19577 Check_Arg_Count
(1);
19578 Check_Arg_Is_Integer_Literal
(Arg1
);
19586 -- The only correct use of this pragma is on its own in a file, in
19587 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19588 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19589 -- check for a file containing nothing but a No_Body pragma). If we
19590 -- attempt to process it during normal semantics processing, it means
19591 -- it was misplaced.
19593 when Pragma_No_Body
=>
19597 -----------------------------
19598 -- No_Elaboration_Code_All --
19599 -----------------------------
19601 -- pragma No_Elaboration_Code_All;
19603 when Pragma_No_Elaboration_Code_All
=>
19605 Check_Valid_Library_Unit_Pragma
;
19607 if Nkind
(N
) = N_Null_Statement
then
19611 -- Must appear for a spec or generic spec
19613 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
19614 N_Generic_Package_Declaration
,
19615 N_Generic_Subprogram_Declaration
,
19616 N_Package_Declaration
,
19617 N_Subprogram_Declaration
)
19621 ("pragma% can only occur for package "
19622 & "or subprogram spec"));
19625 -- Set flag in unit table
19627 Set_No_Elab_Code_All
(Current_Sem_Unit
);
19629 -- Set restriction No_Elaboration_Code if this is the main unit
19631 if Current_Sem_Unit
= Main_Unit
then
19632 Set_Restriction
(No_Elaboration_Code
, N
);
19635 -- If we are in the main unit or in an extended main source unit,
19636 -- then we also add it to the configuration restrictions so that
19637 -- it will apply to all units in the extended main source.
19639 if Current_Sem_Unit
= Main_Unit
19640 or else In_Extended_Main_Source_Unit
(N
)
19642 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
19645 -- If in main extended unit, activate transitive with test
19647 if In_Extended_Main_Source_Unit
(N
) then
19648 Opt
.No_Elab_Code_All_Pragma
:= N
;
19651 -----------------------------
19652 -- No_Component_Reordering --
19653 -----------------------------
19655 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19657 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
19663 Check_At_Most_N_Arguments
(1);
19665 if Arg_Count
= 0 then
19666 Check_Valid_Configuration_Pragma
;
19667 Opt
.No_Component_Reordering
:= True;
19670 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19671 Check_Arg_Is_Local_Name
(Arg1
);
19672 E_Id
:= Get_Pragma_Arg
(Arg1
);
19674 if Etype
(E_Id
) = Any_Type
then
19678 E
:= Entity
(E_Id
);
19680 if not Is_Record_Type
(E
) then
19681 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
19684 Set_No_Reordering
(Base_Type
(E
));
19686 end No_Comp_Reordering
;
19688 --------------------------
19689 -- No_Heap_Finalization --
19690 --------------------------
19692 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19694 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
19695 Context
: constant Node_Id
:= Parent
(N
);
19696 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19702 Check_No_Identifiers
;
19704 -- The pragma appears in a configuration file
19706 if No
(Context
) then
19707 Check_Arg_Count
(0);
19708 Check_Valid_Configuration_Pragma
;
19710 -- Detect a duplicate pragma
19712 if Present
(No_Heap_Finalization_Pragma
) then
19715 Prev
=> No_Heap_Finalization_Pragma
);
19719 No_Heap_Finalization_Pragma
:= N
;
19721 -- Otherwise the pragma should be associated with a library-level
19722 -- named access-to-object type.
19725 Check_Arg_Count
(1);
19726 Check_Arg_Is_Local_Name
(Arg1
);
19728 Find_Type
(Typ_Arg
);
19729 Typ
:= Entity
(Typ_Arg
);
19731 -- The type being subjected to the pragma is erroneous
19733 if Typ
= Any_Type
then
19734 Error_Pragma
("cannot find type referenced by pragma %");
19736 -- The pragma is applied to an incomplete or generic formal
19737 -- type way too early.
19739 elsif Rep_Item_Too_Early
(Typ
, N
) then
19743 Typ
:= Underlying_Type
(Typ
);
19746 -- The pragma must apply to an access-to-object type
19748 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
19751 -- Give a detailed error message on all other access type kinds
19753 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19755 ("pragma % cannot apply to access protected subprogram "
19758 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19760 ("pragma % cannot apply to access subprogram type");
19762 elsif Is_Anonymous_Access_Type
(Typ
) then
19764 ("pragma % cannot apply to anonymous access type");
19766 -- Give a general error message in case the pragma applies to a
19767 -- non-access type.
19771 ("pragma % must apply to library level access type");
19774 -- At this point the argument denotes an access-to-object type.
19775 -- Ensure that the type is declared at the library level.
19777 if Is_Library_Level_Entity
(Typ
) then
19780 -- Quietly ignore an access-to-object type originally declared
19781 -- at the library level within a generic, but instantiated at
19782 -- a non-library level. As a result the access-to-object type
19783 -- "loses" its No_Heap_Finalization property.
19785 elsif In_Instance
then
19790 ("pragma % must apply to library level access type");
19793 -- Detect a duplicate pragma
19795 if Present
(No_Heap_Finalization_Pragma
) then
19798 Prev
=> No_Heap_Finalization_Pragma
);
19802 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19804 if Present
(Prev
) then
19812 Record_Rep_Item
(Typ
, N
);
19814 end No_Heap_Finalization
;
19820 -- pragma No_Inline ( NAME {, NAME} );
19822 when Pragma_No_Inline
=>
19824 Process_Inline
(Suppressed
);
19830 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19832 when Pragma_No_Return
=> No_Return
: declare
19838 Ghost_Error_Posted
: Boolean := False;
19839 -- Flag set when an error concerning the illegal mix of Ghost and
19840 -- non-Ghost subprograms is emitted.
19842 Ghost_Id
: Entity_Id
:= Empty
;
19843 -- The entity of the first Ghost procedure encountered while
19844 -- processing the arguments of the pragma.
19848 Check_At_Least_N_Arguments
(1);
19850 -- Loop through arguments of pragma
19853 while Present
(Arg
) loop
19854 Check_Arg_Is_Local_Name
(Arg
);
19855 Id
:= Get_Pragma_Arg
(Arg
);
19858 if not Is_Entity_Name
(Id
) then
19859 Error_Pragma_Arg
("entity name required", Arg
);
19862 if Etype
(Id
) = Any_Type
then
19866 -- Loop to find matching procedures
19872 and then Scope
(E
) = Current_Scope
19874 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
19876 -- Check that the pragma is not applied to a body.
19877 -- First check the specless body case, to give a
19878 -- different error message. These checks do not apply
19879 -- if Relaxed_RM_Semantics, to accommodate other Ada
19880 -- compilers. Disable these checks under -gnatd.J.
19882 if not Debug_Flag_Dot_JJ
then
19883 if Nkind
(Parent
(Declaration_Node
(E
))) =
19885 and then not Relaxed_RM_Semantics
19888 ("pragma% requires separate spec and must come "
19892 -- Now the "specful" body case
19894 if Rep_Item_Too_Late
(E
, N
) then
19901 -- A pragma that applies to a Ghost entity becomes Ghost
19902 -- for the purposes of legality checks and removal of
19903 -- ignored Ghost code.
19905 Mark_Ghost_Pragma
(N
, E
);
19907 -- Capture the entity of the first Ghost procedure being
19908 -- processed for error detection purposes.
19910 if Is_Ghost_Entity
(E
) then
19911 if No
(Ghost_Id
) then
19915 -- Otherwise the subprogram is non-Ghost. It is illegal
19916 -- to mix references to Ghost and non-Ghost entities
19919 elsif Present
(Ghost_Id
)
19920 and then not Ghost_Error_Posted
19922 Ghost_Error_Posted
:= True;
19924 Error_Msg_Name_1
:= Pname
;
19926 ("pragma % cannot mention ghost and non-ghost "
19927 & "procedures", N
);
19929 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19930 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
19932 Error_Msg_Sloc
:= Sloc
(E
);
19933 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
19936 -- Set flag on any alias as well
19938 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
19939 Set_No_Return
(Alias
(E
));
19945 exit when From_Aspect_Specification
(N
);
19949 -- If entity in not in current scope it may be the enclosing
19950 -- suprogram body to which the aspect applies.
19953 if Entity
(Id
) = Current_Scope
19954 and then From_Aspect_Specification
(N
)
19956 Set_No_Return
(Entity
(Id
));
19958 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
19970 -- pragma No_Run_Time;
19972 -- Note: this pragma is retained for backwards compatibility. See
19973 -- body of Rtsfind for full details on its handling.
19975 when Pragma_No_Run_Time
=>
19977 Check_Valid_Configuration_Pragma
;
19978 Check_Arg_Count
(0);
19980 -- Remove backward compatibility if Build_Type is FSF or GPL and
19981 -- generate a warning.
19984 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
19987 Error_Pragma
("pragma% is ignored, has no effect??");
19989 No_Run_Time_Mode
:= True;
19990 Configurable_Run_Time_Mode
:= True;
19992 -- Set Duration to 32 bits if word size is 32
19994 if Ttypes
.System_Word_Size
= 32 then
19995 Duration_32_Bits_On_Target
:= True;
19998 -- Set appropriate restrictions
20000 Set_Restriction
(No_Finalization
, N
);
20001 Set_Restriction
(No_Exception_Handlers
, N
);
20002 Set_Restriction
(Max_Tasks
, N
, 0);
20003 Set_Restriction
(No_Tasking
, N
);
20007 -----------------------
20008 -- No_Tagged_Streams --
20009 -----------------------
20011 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20013 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20019 Check_At_Most_N_Arguments
(1);
20021 -- One argument case
20023 if Arg_Count
= 1 then
20024 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20025 Check_Arg_Is_Local_Name
(Arg1
);
20026 E_Id
:= Get_Pragma_Arg
(Arg1
);
20028 if Etype
(E_Id
) = Any_Type
then
20032 E
:= Entity
(E_Id
);
20034 Check_Duplicate_Pragma
(E
);
20036 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20038 ("argument for pragma% must be root tagged type", Arg1
);
20041 if Rep_Item_Too_Early
(E
, N
)
20043 Rep_Item_Too_Late
(E
, N
)
20047 Set_No_Tagged_Streams_Pragma
(E
, N
);
20050 -- Zero argument case
20053 Check_Is_In_Decl_Part_Or_Package_Spec
;
20054 No_Tagged_Streams
:= N
;
20056 end No_Tagged_Strms
;
20058 ------------------------
20059 -- No_Strict_Aliasing --
20060 ------------------------
20062 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20064 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20070 Check_At_Most_N_Arguments
(1);
20072 if Arg_Count
= 0 then
20073 Check_Valid_Configuration_Pragma
;
20074 Opt
.No_Strict_Aliasing
:= True;
20077 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20078 Check_Arg_Is_Local_Name
(Arg1
);
20079 E_Id
:= Get_Pragma_Arg
(Arg1
);
20081 if Etype
(E_Id
) = Any_Type
then
20085 E
:= Entity
(E_Id
);
20087 if not Is_Access_Type
(E
) then
20088 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
20091 Set_No_Strict_Aliasing
(Base_Type
(E
));
20093 end No_Strict_Aliasing
;
20095 -----------------------
20096 -- Normalize_Scalars --
20097 -----------------------
20099 -- pragma Normalize_Scalars;
20101 when Pragma_Normalize_Scalars
=>
20102 Check_Ada_83_Warning
;
20103 Check_Arg_Count
(0);
20104 Check_Valid_Configuration_Pragma
;
20106 -- Normalize_Scalars creates false positives in CodePeer, and
20107 -- incorrect negative results in GNATprove mode, so ignore this
20108 -- pragma in these modes.
20110 if not (CodePeer_Mode
or GNATprove_Mode
) then
20111 Normalize_Scalars
:= True;
20112 Init_Or_Norm_Scalars
:= True;
20119 -- pragma Obsolescent;
20121 -- pragma Obsolescent (
20122 -- [Message =>] static_string_EXPRESSION
20123 -- [,[Version =>] Ada_05]]);
20125 -- pragma Obsolescent (
20126 -- [Entity =>] NAME
20127 -- [,[Message =>] static_string_EXPRESSION
20128 -- [,[Version =>] Ada_05]] );
20130 when Pragma_Obsolescent
=> Obsolescent
: declare
20134 procedure Set_Obsolescent
(E
: Entity_Id
);
20135 -- Given an entity Ent, mark it as obsolescent if appropriate
20137 ---------------------
20138 -- Set_Obsolescent --
20139 ---------------------
20141 procedure Set_Obsolescent
(E
: Entity_Id
) is
20150 -- A pragma that applies to a Ghost entity becomes Ghost for
20151 -- the purposes of legality checks and removal of ignored Ghost
20154 Mark_Ghost_Pragma
(N
, E
);
20156 -- Entity name was given
20158 if Present
(Ename
) then
20160 -- If entity name matches, we are fine. Save entity in
20161 -- pragma argument, for ASIS use.
20163 if Chars
(Ename
) = Chars
(Ent
) then
20164 Set_Entity
(Ename
, Ent
);
20165 Generate_Reference
(Ent
, Ename
);
20167 -- If entity name does not match, only possibility is an
20168 -- enumeration literal from an enumeration type declaration.
20170 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
20172 ("pragma % entity name does not match declaration");
20175 Ent
:= First_Literal
(E
);
20179 ("pragma % entity name does not match any "
20180 & "enumeration literal");
20182 elsif Chars
(Ent
) = Chars
(Ename
) then
20183 Set_Entity
(Ename
, Ent
);
20184 Generate_Reference
(Ent
, Ename
);
20188 Ent
:= Next_Literal
(Ent
);
20194 -- Ent points to entity to be marked
20196 if Arg_Count
>= 1 then
20198 -- Deal with static string argument
20200 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20201 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
20203 for J
in 1 .. String_Length
(S
) loop
20204 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
20206 ("pragma% argument does not allow wide characters",
20211 Obsolescent_Warnings
.Append
20212 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
20214 -- Check for Ada_05 parameter
20216 if Arg_Count
/= 1 then
20217 Check_Arg_Count
(2);
20220 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20223 Check_Arg_Is_Identifier
(Argx
);
20225 if Chars
(Argx
) /= Name_Ada_05
then
20226 Error_Msg_Name_2
:= Name_Ada_05
;
20228 ("only allowed argument for pragma% is %", Argx
);
20231 if Ada_Version_Explicit
< Ada_2005
20232 or else not Warn_On_Ada_2005_Compatibility
20240 -- Set flag if pragma active
20243 Set_Is_Obsolescent
(Ent
);
20247 end Set_Obsolescent
;
20249 -- Start of processing for pragma Obsolescent
20254 Check_At_Most_N_Arguments
(3);
20256 -- See if first argument specifies an entity name
20260 (Chars
(Arg1
) = Name_Entity
20262 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
20264 N_Operator_Symbol
))
20266 Ename
:= Get_Pragma_Arg
(Arg1
);
20268 -- Eliminate first argument, so we can share processing
20272 Arg_Count
:= Arg_Count
- 1;
20274 -- No Entity name argument given
20280 if Arg_Count
>= 1 then
20281 Check_Optional_Identifier
(Arg1
, Name_Message
);
20283 if Arg_Count
= 2 then
20284 Check_Optional_Identifier
(Arg2
, Name_Version
);
20288 -- Get immediately preceding declaration
20291 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
20295 -- Cases where we do not follow anything other than another pragma
20299 -- First case: library level compilation unit declaration with
20300 -- the pragma immediately following the declaration.
20302 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
20304 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
20307 -- Case 2: library unit placement for package
20311 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
20313 if Is_Package_Or_Generic_Package
(Ent
) then
20314 Set_Obsolescent
(Ent
);
20320 -- Cases where we must follow a declaration, including an
20321 -- abstract subprogram declaration, which is not in the
20322 -- other node subtypes.
20325 if Nkind
(Decl
) not in N_Declaration
20326 and then Nkind
(Decl
) not in N_Later_Decl_Item
20327 and then Nkind
(Decl
) not in N_Generic_Declaration
20328 and then Nkind
(Decl
) not in N_Renaming_Declaration
20329 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
20332 ("pragma% misplaced, "
20333 & "must immediately follow a declaration");
20336 Set_Obsolescent
(Defining_Entity
(Decl
));
20346 -- pragma Optimize (Time | Space | Off);
20348 -- The actual check for optimize is done in Gigi. Note that this
20349 -- pragma does not actually change the optimization setting, it
20350 -- simply checks that it is consistent with the pragma.
20352 when Pragma_Optimize
=>
20353 Check_No_Identifiers
;
20354 Check_Arg_Count
(1);
20355 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
20357 ------------------------
20358 -- Optimize_Alignment --
20359 ------------------------
20361 -- pragma Optimize_Alignment (Time | Space | Off);
20363 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
20365 Check_No_Identifiers
;
20366 Check_Arg_Count
(1);
20367 Check_Valid_Configuration_Pragma
;
20370 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
20373 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
20374 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
20375 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
20378 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
20382 -- Set indication that mode is set locally. If we are in fact in a
20383 -- configuration pragma file, this setting is harmless since the
20384 -- switch will get reset anyway at the start of each unit.
20386 Optimize_Alignment_Local
:= True;
20387 end Optimize_Alignment
;
20393 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20395 when Pragma_Ordered
=> Ordered
: declare
20396 Assoc
: constant Node_Id
:= Arg1
;
20402 Check_No_Identifiers
;
20403 Check_Arg_Count
(1);
20404 Check_Arg_Is_Local_Name
(Arg1
);
20406 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20407 Find_Type
(Type_Id
);
20408 Typ
:= Entity
(Type_Id
);
20410 if Typ
= Any_Type
then
20413 Typ
:= Underlying_Type
(Typ
);
20416 if not Is_Enumeration_Type
(Typ
) then
20417 Error_Pragma
("pragma% must specify enumeration type");
20420 Check_First_Subtype
(Arg1
);
20421 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
20424 -------------------
20425 -- Overflow_Mode --
20426 -------------------
20428 -- pragma Overflow_Mode
20429 -- ([General => ] MODE [, [Assertions => ] MODE]);
20431 -- MODE := STRICT | MINIMIZED | ELIMINATED
20433 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20434 -- since System.Bignums makes this assumption. This is true of nearly
20435 -- all (all?) targets.
20437 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
20438 function Get_Overflow_Mode
20440 Arg
: Node_Id
) return Overflow_Mode_Type
;
20441 -- Function to process one pragma argument, Arg. If an identifier
20442 -- is present, it must be Name. Mode type is returned if a valid
20443 -- argument exists, otherwise an error is signalled.
20445 -----------------------
20446 -- Get_Overflow_Mode --
20447 -----------------------
20449 function Get_Overflow_Mode
20451 Arg
: Node_Id
) return Overflow_Mode_Type
20453 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
20456 Check_Optional_Identifier
(Arg
, Name
);
20457 Check_Arg_Is_Identifier
(Argx
);
20459 if Chars
(Argx
) = Name_Strict
then
20462 elsif Chars
(Argx
) = Name_Minimized
then
20465 elsif Chars
(Argx
) = Name_Eliminated
then
20466 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
20468 ("Eliminated not implemented on this target", Argx
);
20474 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
20476 end Get_Overflow_Mode
;
20478 -- Start of processing for Overflow_Mode
20482 Check_At_Least_N_Arguments
(1);
20483 Check_At_Most_N_Arguments
(2);
20485 -- Process first argument
20487 Scope_Suppress
.Overflow_Mode_General
:=
20488 Get_Overflow_Mode
(Name_General
, Arg1
);
20490 -- Case of only one argument
20492 if Arg_Count
= 1 then
20493 Scope_Suppress
.Overflow_Mode_Assertions
:=
20494 Scope_Suppress
.Overflow_Mode_General
;
20496 -- Case of two arguments present
20499 Scope_Suppress
.Overflow_Mode_Assertions
:=
20500 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
20504 --------------------------
20505 -- Overriding Renamings --
20506 --------------------------
20508 -- pragma Overriding_Renamings;
20510 when Pragma_Overriding_Renamings
=>
20512 Check_Arg_Count
(0);
20513 Check_Valid_Configuration_Pragma
;
20514 Overriding_Renamings
:= True;
20520 -- pragma Pack (first_subtype_LOCAL_NAME);
20522 when Pragma_Pack
=> Pack
: declare
20523 Assoc
: constant Node_Id
:= Arg1
;
20525 Ignore
: Boolean := False;
20530 Check_No_Identifiers
;
20531 Check_Arg_Count
(1);
20532 Check_Arg_Is_Local_Name
(Arg1
);
20533 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20535 if not Is_Entity_Name
(Type_Id
)
20536 or else not Is_Type
(Entity
(Type_Id
))
20539 ("argument for pragma% must be type or subtype", Arg1
);
20542 Find_Type
(Type_Id
);
20543 Typ
:= Entity
(Type_Id
);
20546 or else Rep_Item_Too_Early
(Typ
, N
)
20550 Typ
:= Underlying_Type
(Typ
);
20553 -- A pragma that applies to a Ghost entity becomes Ghost for the
20554 -- purposes of legality checks and removal of ignored Ghost code.
20556 Mark_Ghost_Pragma
(N
, Typ
);
20558 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
20559 Error_Pragma
("pragma% must specify array or record type");
20562 Check_First_Subtype
(Arg1
);
20563 Check_Duplicate_Pragma
(Typ
);
20567 if Is_Array_Type
(Typ
) then
20568 Ctyp
:= Component_Type
(Typ
);
20570 -- Ignore pack that does nothing
20572 if Known_Static_Esize
(Ctyp
)
20573 and then Known_Static_RM_Size
(Ctyp
)
20574 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
20575 and then Addressable
(Esize
(Ctyp
))
20580 -- Process OK pragma Pack. Note that if there is a separate
20581 -- component clause present, the Pack will be cancelled. This
20582 -- processing is in Freeze.
20584 if not Rep_Item_Too_Late
(Typ
, N
) then
20586 -- In CodePeer mode, we do not need complex front-end
20587 -- expansions related to pragma Pack, so disable handling
20590 if CodePeer_Mode
then
20593 -- Normal case where we do the pack action
20597 Set_Is_Packed
(Base_Type
(Typ
));
20598 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20601 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20605 -- For record types, the pack is always effective
20607 else pragma Assert
(Is_Record_Type
(Typ
));
20608 if not Rep_Item_Too_Late
(Typ
, N
) then
20609 Set_Is_Packed
(Base_Type
(Typ
));
20610 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20611 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20622 -- There is nothing to do here, since we did all the processing for
20623 -- this pragma in Par.Prag (so that it works properly even in syntax
20626 when Pragma_Page
=>
20633 -- pragma Part_Of (ABSTRACT_STATE);
20635 -- ABSTRACT_STATE ::= NAME
20637 when Pragma_Part_Of
=> Part_Of
: declare
20638 procedure Propagate_Part_Of
20639 (Pack_Id
: Entity_Id
;
20640 State_Id
: Entity_Id
;
20641 Instance
: Node_Id
);
20642 -- Propagate the Part_Of indicator to all abstract states and
20643 -- objects declared in the visible state space of a package
20644 -- denoted by Pack_Id. State_Id is the encapsulating state.
20645 -- Instance is the package instantiation node.
20647 -----------------------
20648 -- Propagate_Part_Of --
20649 -----------------------
20651 procedure Propagate_Part_Of
20652 (Pack_Id
: Entity_Id
;
20653 State_Id
: Entity_Id
;
20654 Instance
: Node_Id
)
20656 Has_Item
: Boolean := False;
20657 -- Flag set when the visible state space contains at least one
20658 -- abstract state or variable.
20660 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
20661 -- Propagate the Part_Of indicator to all abstract states and
20662 -- objects declared in the visible state space of a package
20663 -- denoted by Pack_Id.
20665 -----------------------
20666 -- Propagate_Part_Of --
20667 -----------------------
20669 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
20670 Constits
: Elist_Id
;
20671 Item_Id
: Entity_Id
;
20674 -- Traverse the entity chain of the package and set relevant
20675 -- attributes of abstract states and objects declared in the
20676 -- visible state space of the package.
20678 Item_Id
:= First_Entity
(Pack_Id
);
20679 while Present
(Item_Id
)
20680 and then not In_Private_Part
(Item_Id
)
20682 -- Do not consider internally generated items
20684 if not Comes_From_Source
(Item_Id
) then
20687 -- Do not consider generic formals or their corresponding
20688 -- actuals because they are not part of a visible state.
20689 -- Note that both entities are marked as hidden.
20691 elsif Is_Hidden
(Item_Id
) then
20694 -- The Part_Of indicator turns an abstract state or an
20695 -- object into a constituent of the encapsulating state.
20696 -- Note that constants are considered here even though
20697 -- they may not depend on variable input. This check is
20698 -- left to the SPARK prover.
20700 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
20705 Constits
:= Part_Of_Constituents
(State_Id
);
20707 if No
(Constits
) then
20708 Constits
:= New_Elmt_List
;
20709 Set_Part_Of_Constituents
(State_Id
, Constits
);
20712 Append_Elmt
(Item_Id
, Constits
);
20713 Set_Encapsulating_State
(Item_Id
, State_Id
);
20715 -- Recursively handle nested packages and instantiations
20717 elsif Ekind
(Item_Id
) = E_Package
then
20718 Propagate_Part_Of
(Item_Id
);
20721 Next_Entity
(Item_Id
);
20723 end Propagate_Part_Of
;
20725 -- Start of processing for Propagate_Part_Of
20728 Propagate_Part_Of
(Pack_Id
);
20730 -- Detect a package instantiation that is subject to a Part_Of
20731 -- indicator, but has no visible state.
20733 if not Has_Item
then
20735 ("package instantiation & has Part_Of indicator but "
20736 & "lacks visible state", Instance
, Pack_Id
);
20738 end Propagate_Part_Of
;
20742 Constits
: Elist_Id
;
20744 Encap_Id
: Entity_Id
;
20745 Item_Id
: Entity_Id
;
20749 -- Start of processing for Part_Of
20753 Check_No_Identifiers
;
20754 Check_Arg_Count
(1);
20756 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
20758 -- Object declaration
20760 if Nkind
(Stmt
) = N_Object_Declaration
then
20763 -- Package instantiation
20765 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
20768 -- Single concurrent type declaration
20770 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
20773 -- Otherwise the pragma is associated with an illegal construct
20780 -- Extract the entity of the related object declaration or package
20781 -- instantiation. In the case of the instantiation, use the entity
20782 -- of the instance spec.
20784 if Nkind
(Stmt
) = N_Package_Instantiation
then
20785 Stmt
:= Instance_Spec
(Stmt
);
20788 Item_Id
:= Defining_Entity
(Stmt
);
20790 -- A pragma that applies to a Ghost entity becomes Ghost for the
20791 -- purposes of legality checks and removal of ignored Ghost code.
20793 Mark_Ghost_Pragma
(N
, Item_Id
);
20795 -- Chain the pragma on the contract for further processing by
20796 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20798 Add_Contract_Item
(N
, Item_Id
);
20800 -- A variable may act as constituent of a single concurrent type
20801 -- which in turn could be declared after the variable. Due to this
20802 -- discrepancy, the full analysis of indicator Part_Of is delayed
20803 -- until the end of the enclosing declarative region (see routine
20804 -- Analyze_Part_Of_In_Decl_Part).
20806 if Ekind
(Item_Id
) = E_Variable
then
20809 -- Otherwise indicator Part_Of applies to a constant or a package
20813 Encap
:= Get_Pragma_Arg
(Arg1
);
20815 -- Detect any discrepancies between the placement of the
20816 -- constant or package instantiation with respect to state
20817 -- space and the encapsulating state.
20821 Item_Id
=> Item_Id
,
20823 Encap_Id
=> Encap_Id
,
20827 pragma Assert
(Present
(Encap_Id
));
20829 if Ekind
(Item_Id
) = E_Constant
then
20830 Constits
:= Part_Of_Constituents
(Encap_Id
);
20832 if No
(Constits
) then
20833 Constits
:= New_Elmt_List
;
20834 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
20837 Append_Elmt
(Item_Id
, Constits
);
20838 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
20840 -- Propagate the Part_Of indicator to the visible state
20841 -- space of the package instantiation.
20845 (Pack_Id
=> Item_Id
,
20846 State_Id
=> Encap_Id
,
20853 ----------------------------------
20854 -- Partition_Elaboration_Policy --
20855 ----------------------------------
20857 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20859 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
20860 subtype PEP_Range
is Name_Id
20861 range First_Partition_Elaboration_Policy_Name
20862 .. Last_Partition_Elaboration_Policy_Name
;
20863 PEP_Val
: PEP_Range
;
20868 Check_Arg_Count
(1);
20869 Check_No_Identifiers
;
20870 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
20871 Check_Valid_Configuration_Pragma
;
20872 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20875 when Name_Concurrent
=> PEP
:= 'C';
20876 when Name_Sequential
=> PEP
:= 'S';
20879 if Partition_Elaboration_Policy
/= ' '
20880 and then Partition_Elaboration_Policy
/= PEP
20882 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
20884 ("partition elaboration policy incompatible with policy#");
20886 -- Set new policy, but always preserve System_Location since we
20887 -- like the error message with the run time name.
20890 Partition_Elaboration_Policy
:= PEP
;
20892 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
20893 Partition_Elaboration_Policy_Sloc
:= Loc
;
20902 -- pragma Passive [(PASSIVE_FORM)];
20904 -- PASSIVE_FORM ::= Semaphore | No
20906 when Pragma_Passive
=>
20909 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
20910 Error_Pragma
("pragma% must be within task definition");
20913 if Arg_Count
/= 0 then
20914 Check_Arg_Count
(1);
20915 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
20918 ----------------------------------
20919 -- Preelaborable_Initialization --
20920 ----------------------------------
20922 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20924 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
20929 Check_Arg_Count
(1);
20930 Check_No_Identifiers
;
20931 Check_Arg_Is_Identifier
(Arg1
);
20932 Check_Arg_Is_Local_Name
(Arg1
);
20933 Check_First_Subtype
(Arg1
);
20934 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20936 -- A pragma that applies to a Ghost entity becomes Ghost for the
20937 -- purposes of legality checks and removal of ignored Ghost code.
20939 Mark_Ghost_Pragma
(N
, Ent
);
20941 -- The pragma may come from an aspect on a private declaration,
20942 -- even if the freeze point at which this is analyzed in the
20943 -- private part after the full view.
20945 if Has_Private_Declaration
(Ent
)
20946 and then From_Aspect_Specification
(N
)
20950 -- Check appropriate type argument
20952 elsif Is_Private_Type
(Ent
)
20953 or else Is_Protected_Type
(Ent
)
20954 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
20956 -- AI05-0028: The pragma applies to all composite types. Note
20957 -- that we apply this binding interpretation to earlier versions
20958 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20959 -- choice since there are other compilers that do the same.
20961 or else Is_Composite_Type
(Ent
)
20967 ("pragma % can only be applied to private, formal derived, "
20968 & "protected, or composite type", Arg1
);
20971 -- Give an error if the pragma is applied to a protected type that
20972 -- does not qualify (due to having entries, or due to components
20973 -- that do not qualify).
20975 if Is_Protected_Type
(Ent
)
20976 and then not Has_Preelaborable_Initialization
(Ent
)
20979 ("protected type & does not have preelaborable "
20980 & "initialization", Ent
);
20982 -- Otherwise mark the type as definitely having preelaborable
20986 Set_Known_To_Have_Preelab_Init
(Ent
);
20989 if Has_Pragma_Preelab_Init
(Ent
)
20990 and then Warn_On_Redundant_Constructs
20992 Error_Pragma
("?r?duplicate pragma%!");
20994 Set_Has_Pragma_Preelab_Init
(Ent
);
20998 --------------------
20999 -- Persistent_BSS --
21000 --------------------
21002 -- pragma Persistent_BSS [(object_NAME)];
21004 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21011 Check_At_Most_N_Arguments
(1);
21013 -- Case of application to specific object (one argument)
21015 if Arg_Count
= 1 then
21016 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21018 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21020 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
21023 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21026 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21028 -- A pragma that applies to a Ghost entity becomes Ghost for
21029 -- the purposes of legality checks and removal of ignored Ghost
21032 Mark_Ghost_Pragma
(N
, Ent
);
21034 -- Check for duplication before inserting in list of
21035 -- representation items.
21037 Check_Duplicate_Pragma
(Ent
);
21039 if Rep_Item_Too_Late
(Ent
, N
) then
21043 Decl
:= Parent
(Ent
);
21045 if Present
(Expression
(Decl
)) then
21047 ("object for pragma% cannot have initialization", Arg1
);
21050 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
21052 ("object type for pragma% is not potentially persistent",
21057 Make_Linker_Section_Pragma
21058 (Ent
, Sloc
(N
), ".persistent.bss");
21059 Insert_After
(N
, Prag
);
21062 -- Case of use as configuration pragma with no arguments
21065 Check_Valid_Configuration_Pragma
;
21066 Persistent_BSS_Mode
:= True;
21068 end Persistent_BSS
;
21070 --------------------
21071 -- Rename_Pragma --
21072 --------------------
21074 -- pragma Rename_Pragma (
21075 -- [New_Name =>] IDENTIFIER,
21076 -- [Renamed =>] pragma_IDENTIFIER);
21078 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
21079 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21080 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21084 Check_Valid_Configuration_Pragma
;
21085 Check_Arg_Count
(2);
21086 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
21087 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
21089 if Nkind
(New_Name
) /= N_Identifier
then
21090 Error_Pragma_Arg
("identifier expected", Arg1
);
21093 if Nkind
(Old_Name
) /= N_Identifier
then
21094 Error_Pragma_Arg
("identifier expected", Arg2
);
21097 -- The New_Name arg should not be an existing pragma (but we allow
21098 -- it; it's just a warning). The Old_Name arg must be an existing
21101 if Is_Pragma_Name
(Chars
(New_Name
)) then
21102 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
21105 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
21106 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
21109 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
21116 -- pragma Polling (ON | OFF);
21118 when Pragma_Polling
=>
21120 Check_Arg_Count
(1);
21121 Check_No_Identifiers
;
21122 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21123 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
21125 -----------------------------------
21126 -- Post/Post_Class/Postcondition --
21127 -----------------------------------
21129 -- pragma Post (Boolean_EXPRESSION);
21130 -- pragma Post_Class (Boolean_EXPRESSION);
21131 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21132 -- [,[Message =>] String_EXPRESSION]);
21134 -- Characteristics:
21136 -- * Analysis - The annotation undergoes initial checks to verify
21137 -- the legal placement and context. Secondary checks preanalyze the
21140 -- Analyze_Pre_Post_Condition_In_Decl_Part
21142 -- * Expansion - The annotation is expanded during the expansion of
21143 -- the related subprogram [body] contract as performed in:
21145 -- Expand_Subprogram_Contract
21147 -- * Template - The annotation utilizes the generic template of the
21148 -- related subprogram [body] when it is:
21150 -- aspect on subprogram declaration
21151 -- aspect on stand-alone subprogram body
21152 -- pragma on stand-alone subprogram body
21154 -- The annotation must prepare its own template when it is:
21156 -- pragma on subprogram declaration
21158 -- * Globals - Capture of global references must occur after full
21161 -- * Instance - The annotation is instantiated automatically when
21162 -- the related generic subprogram [body] is instantiated except for
21163 -- the "pragma on subprogram declaration" case. In that scenario
21164 -- the annotation must instantiate itself.
21167 | Pragma_Post_Class
21168 | Pragma_Postcondition
21170 Analyze_Pre_Post_Condition
;
21172 --------------------------------
21173 -- Pre/Pre_Class/Precondition --
21174 --------------------------------
21176 -- pragma Pre (Boolean_EXPRESSION);
21177 -- pragma Pre_Class (Boolean_EXPRESSION);
21178 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21179 -- [,[Message =>] String_EXPRESSION]);
21181 -- Characteristics:
21183 -- * Analysis - The annotation undergoes initial checks to verify
21184 -- the legal placement and context. Secondary checks preanalyze the
21187 -- Analyze_Pre_Post_Condition_In_Decl_Part
21189 -- * Expansion - The annotation is expanded during the expansion of
21190 -- the related subprogram [body] contract as performed in:
21192 -- Expand_Subprogram_Contract
21194 -- * Template - The annotation utilizes the generic template of the
21195 -- related subprogram [body] when it is:
21197 -- aspect on subprogram declaration
21198 -- aspect on stand-alone subprogram body
21199 -- pragma on stand-alone subprogram body
21201 -- The annotation must prepare its own template when it is:
21203 -- pragma on subprogram declaration
21205 -- * Globals - Capture of global references must occur after full
21208 -- * Instance - The annotation is instantiated automatically when
21209 -- the related generic subprogram [body] is instantiated except for
21210 -- the "pragma on subprogram declaration" case. In that scenario
21211 -- the annotation must instantiate itself.
21215 | Pragma_Precondition
21217 Analyze_Pre_Post_Condition
;
21223 -- pragma Predicate
21224 -- ([Entity =>] type_LOCAL_NAME,
21225 -- [Check =>] boolean_EXPRESSION);
21227 when Pragma_Predicate
=> Predicate
: declare
21234 Check_Arg_Count
(2);
21235 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21236 Check_Optional_Identifier
(Arg2
, Name_Check
);
21238 Check_Arg_Is_Local_Name
(Arg1
);
21240 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21241 Find_Type
(Type_Id
);
21242 Typ
:= Entity
(Type_Id
);
21244 if Typ
= Any_Type
then
21248 -- A pragma that applies to a Ghost entity becomes Ghost for the
21249 -- purposes of legality checks and removal of ignored Ghost code.
21251 Mark_Ghost_Pragma
(N
, Typ
);
21253 -- The remaining processing is simply to link the pragma on to
21254 -- the rep item chain, for processing when the type is frozen.
21255 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21256 -- mark the type as having predicates.
21258 -- If the current policy for predicate checking is Ignore mark the
21259 -- subtype accordingly. In the case of predicates we consider them
21260 -- enabled unless Ignore is specified (either directly or with a
21261 -- general Assertion_Policy pragma) to preserve existing warnings.
21263 Set_Has_Predicates
(Typ
);
21265 -- Indicate that the pragma must be processed at the point the
21266 -- type is frozen, as is done for the corresponding aspect.
21268 Set_Has_Delayed_Aspects
(Typ
);
21269 Set_Has_Delayed_Freeze
(Typ
);
21271 Set_Predicates_Ignored
(Typ
,
21272 Present
(Check_Policy_List
)
21274 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
21275 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21278 -----------------------
21279 -- Predicate_Failure --
21280 -----------------------
21282 -- pragma Predicate_Failure
21283 -- ([Entity =>] type_LOCAL_NAME,
21284 -- [Message =>] string_EXPRESSION);
21286 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
21293 Check_Arg_Count
(2);
21294 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21295 Check_Optional_Identifier
(Arg2
, Name_Message
);
21297 Check_Arg_Is_Local_Name
(Arg1
);
21299 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21300 Find_Type
(Type_Id
);
21301 Typ
:= Entity
(Type_Id
);
21303 if Typ
= Any_Type
then
21307 -- A pragma that applies to a Ghost entity becomes Ghost for the
21308 -- purposes of legality checks and removal of ignored Ghost code.
21310 Mark_Ghost_Pragma
(N
, Typ
);
21312 -- The remaining processing is simply to link the pragma on to
21313 -- the rep item chain, for processing when the type is frozen.
21314 -- This is accomplished by a call to Rep_Item_Too_Late.
21316 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21317 end Predicate_Failure
;
21323 -- pragma Preelaborate [(library_unit_NAME)];
21325 -- Set the flag Is_Preelaborated of program unit name entity
21327 when Pragma_Preelaborate
=> Preelaborate
: declare
21328 Pa
: constant Node_Id
:= Parent
(N
);
21329 Pk
: constant Node_Kind
:= Nkind
(Pa
);
21333 Check_Ada_83_Warning
;
21334 Check_Valid_Library_Unit_Pragma
;
21336 if Nkind
(N
) = N_Null_Statement
then
21340 Ent
:= Find_Lib_Unit_Name
;
21342 -- A pragma that applies to a Ghost entity becomes Ghost for the
21343 -- purposes of legality checks and removal of ignored Ghost code.
21345 Mark_Ghost_Pragma
(N
, Ent
);
21346 Check_Duplicate_Pragma
(Ent
);
21348 -- This filters out pragmas inside generic parents that show up
21349 -- inside instantiations. Pragmas that come from aspects in the
21350 -- unit are not ignored.
21352 if Present
(Ent
) then
21353 if Pk
= N_Package_Specification
21354 and then Present
(Generic_Parent
(Pa
))
21355 and then not From_Aspect_Specification
(N
)
21360 if not Debug_Flag_U
then
21361 Set_Is_Preelaborated
(Ent
);
21363 if Legacy_Elaboration_Checks
then
21364 Set_Suppress_Elaboration_Warnings
(Ent
);
21371 -------------------------------
21372 -- Prefix_Exception_Messages --
21373 -------------------------------
21375 -- pragma Prefix_Exception_Messages;
21377 when Pragma_Prefix_Exception_Messages
=>
21379 Check_Valid_Configuration_Pragma
;
21380 Check_Arg_Count
(0);
21381 Prefix_Exception_Messages
:= True;
21387 -- pragma Priority (EXPRESSION);
21389 when Pragma_Priority
=> Priority
: declare
21390 P
: constant Node_Id
:= Parent
(N
);
21395 Check_No_Identifiers
;
21396 Check_Arg_Count
(1);
21400 if Nkind
(P
) = N_Subprogram_Body
then
21401 Check_In_Main_Program
;
21403 Ent
:= Defining_Unit_Name
(Specification
(P
));
21405 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
21406 Ent
:= Defining_Identifier
(Ent
);
21409 Arg
:= Get_Pragma_Arg
(Arg1
);
21410 Analyze_And_Resolve
(Arg
, Standard_Integer
);
21414 if not Is_OK_Static_Expression
(Arg
) then
21415 Flag_Non_Static_Expr
21416 ("main subprogram priority is not static!", Arg
);
21419 -- If constraint error, then we already signalled an error
21421 elsif Raises_Constraint_Error
(Arg
) then
21424 -- Otherwise check in range except if Relaxed_RM_Semantics
21425 -- where we ignore the value if out of range.
21428 if not Relaxed_RM_Semantics
21429 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
21432 ("main subprogram priority is out of range", Arg1
);
21435 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
21439 -- Load an arbitrary entity from System.Tasking.Stages or
21440 -- System.Tasking.Restricted.Stages (depending on the
21441 -- supported profile) to make sure that one of these packages
21442 -- is implicitly with'ed, since we need to have the tasking
21443 -- run time active for the pragma Priority to have any effect.
21444 -- Previously we with'ed the package System.Tasking, but this
21445 -- package does not trigger the required initialization of the
21446 -- run-time library.
21449 Discard
: Entity_Id
;
21450 pragma Warnings
(Off
, Discard
);
21452 if Restricted_Profile
then
21453 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
21455 Discard
:= RTE
(RE_Activate_Tasks
);
21459 -- Task or Protected, must be of type Integer
21461 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
21462 Arg
:= Get_Pragma_Arg
(Arg1
);
21463 Ent
:= Defining_Identifier
(Parent
(P
));
21465 -- The expression must be analyzed in the special manner
21466 -- described in "Handling of Default and Per-Object
21467 -- Expressions" in sem.ads.
21469 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
21471 if not Is_OK_Static_Expression
(Arg
) then
21472 Check_Restriction
(Static_Priorities
, Arg
);
21475 -- Anything else is incorrect
21481 -- Check duplicate pragma before we chain the pragma in the Rep
21482 -- Item chain of Ent.
21484 Check_Duplicate_Pragma
(Ent
);
21485 Record_Rep_Item
(Ent
, N
);
21488 -----------------------------------
21489 -- Priority_Specific_Dispatching --
21490 -----------------------------------
21492 -- pragma Priority_Specific_Dispatching (
21493 -- policy_IDENTIFIER,
21494 -- first_priority_EXPRESSION,
21495 -- last_priority_EXPRESSION);
21497 when Pragma_Priority_Specific_Dispatching
=>
21498 Priority_Specific_Dispatching
: declare
21499 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
21500 -- This is the entity System.Any_Priority;
21503 Lower_Bound
: Node_Id
;
21504 Upper_Bound
: Node_Id
;
21510 Check_Arg_Count
(3);
21511 Check_No_Identifiers
;
21512 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21513 Check_Valid_Configuration_Pragma
;
21514 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21515 DP
:= Fold_Upper
(Name_Buffer
(1));
21517 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
21518 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
21519 Lower_Val
:= Expr_Value
(Lower_Bound
);
21521 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
21522 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
21523 Upper_Val
:= Expr_Value
(Upper_Bound
);
21525 -- It is not allowed to use Task_Dispatching_Policy and
21526 -- Priority_Specific_Dispatching in the same partition.
21528 if Task_Dispatching_Policy
/= ' ' then
21529 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21531 ("pragma% incompatible with Task_Dispatching_Policy#");
21533 -- Check lower bound in range
21535 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21537 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21540 ("first_priority is out of range", Arg2
);
21542 -- Check upper bound in range
21544 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21546 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21549 ("last_priority is out of range", Arg3
);
21551 -- Check that the priority range is valid
21553 elsif Lower_Val
> Upper_Val
then
21555 ("last_priority_expression must be greater than or equal to "
21556 & "first_priority_expression");
21558 -- Store the new policy, but always preserve System_Location since
21559 -- we like the error message with the run-time name.
21562 -- Check overlapping in the priority ranges specified in other
21563 -- Priority_Specific_Dispatching pragmas within the same
21564 -- partition. We can only check those we know about.
21567 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
21569 if Specific_Dispatching
.Table
(J
).First_Priority
in
21570 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21571 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
21572 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21575 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
21577 ("priority range overlaps with "
21578 & "Priority_Specific_Dispatching#");
21582 -- The use of Priority_Specific_Dispatching is incompatible
21583 -- with Task_Dispatching_Policy.
21585 if Task_Dispatching_Policy
/= ' ' then
21586 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21588 ("Priority_Specific_Dispatching incompatible "
21589 & "with Task_Dispatching_Policy#");
21592 -- The use of Priority_Specific_Dispatching forces ceiling
21595 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
21596 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
21598 ("Priority_Specific_Dispatching incompatible "
21599 & "with Locking_Policy#");
21601 -- Set the Ceiling_Locking policy, but preserve System_Location
21602 -- since we like the error message with the run time name.
21605 Locking_Policy
:= 'C';
21607 if Locking_Policy_Sloc
/= System_Location
then
21608 Locking_Policy_Sloc
:= Loc
;
21612 -- Add entry in the table
21614 Specific_Dispatching
.Append
21615 ((Dispatching_Policy
=> DP
,
21616 First_Priority
=> UI_To_Int
(Lower_Val
),
21617 Last_Priority
=> UI_To_Int
(Upper_Val
),
21618 Pragma_Loc
=> Loc
));
21620 end Priority_Specific_Dispatching
;
21626 -- pragma Profile (profile_IDENTIFIER);
21628 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21630 when Pragma_Profile
=>
21632 Check_Arg_Count
(1);
21633 Check_Valid_Configuration_Pragma
;
21634 Check_No_Identifiers
;
21637 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21640 if Chars
(Argx
) = Name_Ravenscar
then
21641 Set_Ravenscar_Profile
(Ravenscar
, N
);
21643 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
21644 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
21646 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
21647 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
21649 elsif Chars
(Argx
) = Name_Restricted
then
21650 Set_Profile_Restrictions
21652 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21654 elsif Chars
(Argx
) = Name_Rational
then
21655 Set_Rational_Profile
;
21657 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21658 Set_Profile_Restrictions
21659 (No_Implementation_Extensions
,
21660 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21663 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21667 ----------------------
21668 -- Profile_Warnings --
21669 ----------------------
21671 -- pragma Profile_Warnings (profile_IDENTIFIER);
21673 -- profile_IDENTIFIER => Restricted | Ravenscar
21675 when Pragma_Profile_Warnings
=>
21677 Check_Arg_Count
(1);
21678 Check_Valid_Configuration_Pragma
;
21679 Check_No_Identifiers
;
21682 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21685 if Chars
(Argx
) = Name_Ravenscar
then
21686 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
21688 elsif Chars
(Argx
) = Name_Restricted
then
21689 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
21691 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21692 Set_Profile_Restrictions
21693 (No_Implementation_Extensions
, N
, Warn
=> True);
21696 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21700 --------------------------
21701 -- Propagate_Exceptions --
21702 --------------------------
21704 -- pragma Propagate_Exceptions;
21706 -- Note: this pragma is obsolete and has no effect
21708 when Pragma_Propagate_Exceptions
=>
21710 Check_Arg_Count
(0);
21712 if Warn_On_Obsolescent_Feature
then
21714 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21715 "and has no effect?j?", N
);
21718 -----------------------------
21719 -- Provide_Shift_Operators --
21720 -----------------------------
21722 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21724 when Pragma_Provide_Shift_Operators
=>
21725 Provide_Shift_Operators
: declare
21728 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21729 -- Insert declaration and pragma Instrinsic for named shift op
21731 ----------------------------
21732 -- Declare_Shift_Operator --
21733 ----------------------------
21735 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
21741 Make_Subprogram_Declaration
(Loc
,
21742 Make_Function_Specification
(Loc
,
21743 Defining_Unit_Name
=>
21744 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
21746 Result_Definition
=>
21747 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
21749 Parameter_Specifications
=> New_List
(
21750 Make_Parameter_Specification
(Loc
,
21751 Defining_Identifier
=>
21752 Make_Defining_Identifier
(Loc
, Name_Value
),
21754 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
21756 Make_Parameter_Specification
(Loc
,
21757 Defining_Identifier
=>
21758 Make_Defining_Identifier
(Loc
, Name_Amount
),
21760 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
21764 Chars
=> Name_Import
,
21765 Pragma_Argument_Associations
=> New_List
(
21766 Make_Pragma_Argument_Association
(Loc
,
21767 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
21768 Make_Pragma_Argument_Association
(Loc
,
21769 Expression
=> Make_Identifier
(Loc
, Nam
))));
21771 Insert_After
(N
, Import
);
21772 Insert_After
(N
, Func
);
21773 end Declare_Shift_Operator
;
21775 -- Start of processing for Provide_Shift_Operators
21779 Check_Arg_Count
(1);
21780 Check_Arg_Is_Local_Name
(Arg1
);
21782 Arg1
:= Get_Pragma_Arg
(Arg1
);
21784 -- We must have an entity name
21786 if not Is_Entity_Name
(Arg1
) then
21788 ("pragma % must apply to integer first subtype", Arg1
);
21791 -- If no Entity, means there was a prior error so ignore
21793 if Present
(Entity
(Arg1
)) then
21794 Ent
:= Entity
(Arg1
);
21796 -- Apply error checks
21798 if not Is_First_Subtype
(Ent
) then
21800 ("cannot apply pragma %",
21801 "\& is not a first subtype",
21804 elsif not Is_Integer_Type
(Ent
) then
21806 ("cannot apply pragma %",
21807 "\& is not an integer type",
21810 elsif Has_Shift_Operator
(Ent
) then
21812 ("cannot apply pragma %",
21813 "\& already has declared shift operators",
21816 elsif Is_Frozen
(Ent
) then
21818 ("pragma % appears too late",
21819 "\& is already frozen",
21823 -- Now declare the operators. We do this during analysis rather
21824 -- than expansion, since we want the operators available if we
21825 -- are operating in -gnatc or ASIS mode.
21827 Declare_Shift_Operator
(Name_Rotate_Left
);
21828 Declare_Shift_Operator
(Name_Rotate_Right
);
21829 Declare_Shift_Operator
(Name_Shift_Left
);
21830 Declare_Shift_Operator
(Name_Shift_Right
);
21831 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
21833 end Provide_Shift_Operators
;
21839 -- pragma Psect_Object (
21840 -- [Internal =>] LOCAL_NAME,
21841 -- [, [External =>] EXTERNAL_SYMBOL]
21842 -- [, [Size =>] EXTERNAL_SYMBOL]);
21844 when Pragma_Common_Object
21845 | Pragma_Psect_Object
21847 Psect_Object
: declare
21848 Args
: Args_List
(1 .. 3);
21849 Names
: constant Name_List
(1 .. 3) := (
21854 Internal
: Node_Id
renames Args
(1);
21855 External
: Node_Id
renames Args
(2);
21856 Size
: Node_Id
renames Args
(3);
21858 Def_Id
: Entity_Id
;
21860 procedure Check_Arg
(Arg
: Node_Id
);
21861 -- Checks that argument is either a string literal or an
21862 -- identifier, and posts error message if not.
21868 procedure Check_Arg
(Arg
: Node_Id
) is
21870 if not Nkind_In
(Original_Node
(Arg
),
21875 ("inappropriate argument for pragma %", Arg
);
21879 -- Start of processing for Common_Object/Psect_Object
21883 Gather_Associations
(Names
, Args
);
21884 Process_Extended_Import_Export_Internal_Arg
(Internal
);
21886 Def_Id
:= Entity
(Internal
);
21888 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
21890 ("pragma% must designate an object", Internal
);
21893 Check_Arg
(Internal
);
21895 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
21897 ("cannot use pragma% for imported/exported object",
21901 if Is_Concurrent_Type
(Etype
(Internal
)) then
21903 ("cannot specify pragma % for task/protected object",
21907 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
21909 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
21911 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
21914 if Ekind
(Def_Id
) = E_Constant
then
21916 ("cannot specify pragma % for a constant", Internal
);
21919 if Is_Record_Type
(Etype
(Internal
)) then
21925 Ent
:= First_Entity
(Etype
(Internal
));
21926 while Present
(Ent
) loop
21927 Decl
:= Declaration_Node
(Ent
);
21929 if Ekind
(Ent
) = E_Component
21930 and then Nkind
(Decl
) = N_Component_Declaration
21931 and then Present
(Expression
(Decl
))
21932 and then Warn_On_Export_Import
21935 ("?x?object for pragma % has defaults", Internal
);
21945 if Present
(Size
) then
21949 if Present
(External
) then
21950 Check_Arg_Is_External_Name
(External
);
21953 -- If all error tests pass, link pragma on to the rep item chain
21955 Record_Rep_Item
(Def_Id
, N
);
21962 -- pragma Pure [(library_unit_NAME)];
21964 when Pragma_Pure
=> Pure
: declare
21968 Check_Ada_83_Warning
;
21970 -- If the pragma comes from a subprogram instantiation, nothing to
21971 -- check, this can happen at any level of nesting.
21973 if Is_Wrapper_Package
(Current_Scope
) then
21976 Check_Valid_Library_Unit_Pragma
;
21979 if Nkind
(N
) = N_Null_Statement
then
21983 Ent
:= Find_Lib_Unit_Name
;
21985 -- A pragma that applies to a Ghost entity becomes Ghost for the
21986 -- purposes of legality checks and removal of ignored Ghost code.
21988 Mark_Ghost_Pragma
(N
, Ent
);
21990 if not Debug_Flag_U
then
21992 Set_Has_Pragma_Pure
(Ent
);
21994 if Legacy_Elaboration_Checks
then
21995 Set_Suppress_Elaboration_Warnings
(Ent
);
22000 -------------------
22001 -- Pure_Function --
22002 -------------------
22004 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22006 when Pragma_Pure_Function
=> Pure_Function
: declare
22007 Def_Id
: Entity_Id
;
22010 Effective
: Boolean := False;
22011 Orig_Def
: Entity_Id
;
22012 Same_Decl
: Boolean := False;
22016 Check_Arg_Count
(1);
22017 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22018 Check_Arg_Is_Local_Name
(Arg1
);
22019 E_Id
:= Get_Pragma_Arg
(Arg1
);
22021 if Etype
(E_Id
) = Any_Type
then
22025 -- Loop through homonyms (overloadings) of referenced entity
22027 E
:= Entity
(E_Id
);
22029 -- A pragma that applies to a Ghost entity becomes Ghost for the
22030 -- purposes of legality checks and removal of ignored Ghost code.
22032 Mark_Ghost_Pragma
(N
, E
);
22034 if Present
(E
) then
22036 Def_Id
:= Get_Base_Subprogram
(E
);
22038 if not Ekind_In
(Def_Id
, E_Function
,
22039 E_Generic_Function
,
22043 ("pragma% requires a function name", Arg1
);
22046 -- When we have a generic function we must jump up a level
22047 -- to the declaration of the wrapper package itself.
22049 Orig_Def
:= Def_Id
;
22051 if Is_Generic_Instance
(Def_Id
) then
22052 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
22053 Orig_Def
:= Parent
(Orig_Def
);
22057 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
22059 Set_Is_Pure
(Def_Id
);
22061 if not Has_Pragma_Pure_Function
(Def_Id
) then
22062 Set_Has_Pragma_Pure_Function
(Def_Id
);
22067 exit when From_Aspect_Specification
(N
);
22069 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
22073 and then Warn_On_Redundant_Constructs
22076 ("pragma Pure_Function on& is redundant?r?",
22079 elsif not Same_Decl
then
22081 ("pragma% argument must be in same declarative part",
22087 --------------------
22088 -- Queuing_Policy --
22089 --------------------
22091 -- pragma Queuing_Policy (policy_IDENTIFIER);
22093 when Pragma_Queuing_Policy
=> declare
22097 Check_Ada_83_Warning
;
22098 Check_Arg_Count
(1);
22099 Check_No_Identifiers
;
22100 Check_Arg_Is_Queuing_Policy
(Arg1
);
22101 Check_Valid_Configuration_Pragma
;
22102 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22103 QP
:= Fold_Upper
(Name_Buffer
(1));
22105 if Queuing_Policy
/= ' '
22106 and then Queuing_Policy
/= QP
22108 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
22109 Error_Pragma
("queuing policy incompatible with policy#");
22111 -- Set new policy, but always preserve System_Location since we
22112 -- like the error message with the run time name.
22115 Queuing_Policy
:= QP
;
22117 if Queuing_Policy_Sloc
/= System_Location
then
22118 Queuing_Policy_Sloc
:= Loc
;
22127 -- pragma Rational, for compatibility with foreign compiler
22129 when Pragma_Rational
=>
22130 Set_Rational_Profile
;
22132 ---------------------
22133 -- Refined_Depends --
22134 ---------------------
22136 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22138 -- DEPENDENCY_RELATION ::=
22140 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22142 -- DEPENDENCY_CLAUSE ::=
22143 -- OUTPUT_LIST =>[+] INPUT_LIST
22144 -- | NULL_DEPENDENCY_CLAUSE
22146 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22148 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22150 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22152 -- OUTPUT ::= NAME | FUNCTION_RESULT
22155 -- where FUNCTION_RESULT is a function Result attribute_reference
22157 -- Characteristics:
22159 -- * Analysis - The annotation undergoes initial checks to verify
22160 -- the legal placement and context. Secondary checks fully analyze
22161 -- the dependency clauses/global list in:
22163 -- Analyze_Refined_Depends_In_Decl_Part
22165 -- * Expansion - None.
22167 -- * Template - The annotation utilizes the generic template of the
22168 -- related subprogram body.
22170 -- * Globals - Capture of global references must occur after full
22173 -- * Instance - The annotation is instantiated automatically when
22174 -- the related generic subprogram body is instantiated.
22176 when Pragma_Refined_Depends
=> Refined_Depends
: declare
22177 Body_Id
: Entity_Id
;
22179 Spec_Id
: Entity_Id
;
22182 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22186 -- Chain the pragma on the contract for further processing by
22187 -- Analyze_Refined_Depends_In_Decl_Part.
22189 Add_Contract_Item
(N
, Body_Id
);
22191 -- The legality checks of pragmas Refined_Depends and
22192 -- Refined_Global are affected by the SPARK mode in effect and
22193 -- the volatility of the context. In addition these two pragmas
22194 -- are subject to an inherent order:
22196 -- 1) Refined_Global
22197 -- 2) Refined_Depends
22199 -- Analyze all these pragmas in the order outlined above
22201 Analyze_If_Present
(Pragma_SPARK_Mode
);
22202 Analyze_If_Present
(Pragma_Volatile_Function
);
22203 Analyze_If_Present
(Pragma_Refined_Global
);
22204 Analyze_Refined_Depends_In_Decl_Part
(N
);
22206 end Refined_Depends
;
22208 --------------------
22209 -- Refined_Global --
22210 --------------------
22212 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22214 -- GLOBAL_SPECIFICATION ::=
22217 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22219 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22221 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22222 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22223 -- GLOBAL_ITEM ::= NAME
22225 -- Characteristics:
22227 -- * Analysis - The annotation undergoes initial checks to verify
22228 -- the legal placement and context. Secondary checks fully analyze
22229 -- the dependency clauses/global list in:
22231 -- Analyze_Refined_Global_In_Decl_Part
22233 -- * Expansion - None.
22235 -- * Template - The annotation utilizes the generic template of the
22236 -- related subprogram body.
22238 -- * Globals - Capture of global references must occur after full
22241 -- * Instance - The annotation is instantiated automatically when
22242 -- the related generic subprogram body is instantiated.
22244 when Pragma_Refined_Global
=> Refined_Global
: declare
22245 Body_Id
: Entity_Id
;
22247 Spec_Id
: Entity_Id
;
22250 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22254 -- Chain the pragma on the contract for further processing by
22255 -- Analyze_Refined_Global_In_Decl_Part.
22257 Add_Contract_Item
(N
, Body_Id
);
22259 -- The legality checks of pragmas Refined_Depends and
22260 -- Refined_Global are affected by the SPARK mode in effect and
22261 -- the volatility of the context. In addition these two pragmas
22262 -- are subject to an inherent order:
22264 -- 1) Refined_Global
22265 -- 2) Refined_Depends
22267 -- Analyze all these pragmas in the order outlined above
22269 Analyze_If_Present
(Pragma_SPARK_Mode
);
22270 Analyze_If_Present
(Pragma_Volatile_Function
);
22271 Analyze_Refined_Global_In_Decl_Part
(N
);
22272 Analyze_If_Present
(Pragma_Refined_Depends
);
22274 end Refined_Global
;
22280 -- pragma Refined_Post (boolean_EXPRESSION);
22282 -- Characteristics:
22284 -- * Analysis - The annotation is fully analyzed immediately upon
22285 -- elaboration as it cannot forward reference entities.
22287 -- * Expansion - The annotation is expanded during the expansion of
22288 -- the related subprogram body contract as performed in:
22290 -- Expand_Subprogram_Contract
22292 -- * Template - The annotation utilizes the generic template of the
22293 -- related subprogram body.
22295 -- * Globals - Capture of global references must occur after full
22298 -- * Instance - The annotation is instantiated automatically when
22299 -- the related generic subprogram body is instantiated.
22301 when Pragma_Refined_Post
=> Refined_Post
: declare
22302 Body_Id
: Entity_Id
;
22304 Spec_Id
: Entity_Id
;
22307 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22309 -- Fully analyze the pragma when it appears inside a subprogram
22310 -- body because it cannot benefit from forward references.
22314 -- Chain the pragma on the contract for completeness
22316 Add_Contract_Item
(N
, Body_Id
);
22318 -- The legality checks of pragma Refined_Post are affected by
22319 -- the SPARK mode in effect and the volatility of the context.
22320 -- Analyze all pragmas in a specific order.
22322 Analyze_If_Present
(Pragma_SPARK_Mode
);
22323 Analyze_If_Present
(Pragma_Volatile_Function
);
22324 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
22326 -- Currently it is not possible to inline pre/postconditions on
22327 -- a subprogram subject to pragma Inline_Always.
22329 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
22333 -------------------
22334 -- Refined_State --
22335 -------------------
22337 -- pragma Refined_State (REFINEMENT_LIST);
22339 -- REFINEMENT_LIST ::=
22340 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22342 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22344 -- CONSTITUENT_LIST ::=
22347 -- | (CONSTITUENT {, CONSTITUENT})
22349 -- CONSTITUENT ::= object_NAME | state_NAME
22351 -- Characteristics:
22353 -- * Analysis - The annotation undergoes initial checks to verify
22354 -- the legal placement and context. Secondary checks preanalyze the
22355 -- refinement clauses in:
22357 -- Analyze_Refined_State_In_Decl_Part
22359 -- * Expansion - None.
22361 -- * Template - The annotation utilizes the template of the related
22364 -- * Globals - Capture of global references must occur after full
22367 -- * Instance - The annotation is instantiated automatically when
22368 -- the related generic package body is instantiated.
22370 when Pragma_Refined_State
=> Refined_State
: declare
22371 Pack_Decl
: Node_Id
;
22372 Spec_Id
: Entity_Id
;
22376 Check_No_Identifiers
;
22377 Check_Arg_Count
(1);
22379 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
22381 if Nkind
(Pack_Decl
) /= N_Package_Body
then
22386 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
22388 -- A pragma that applies to a Ghost entity becomes Ghost for the
22389 -- purposes of legality checks and removal of ignored Ghost code.
22391 Mark_Ghost_Pragma
(N
, Spec_Id
);
22393 -- Chain the pragma on the contract for further processing by
22394 -- Analyze_Refined_State_In_Decl_Part.
22396 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
22398 -- The legality checks of pragma Refined_State are affected by the
22399 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22401 Analyze_If_Present
(Pragma_SPARK_Mode
);
22403 -- State refinement is allowed only when the corresponding package
22404 -- declaration has non-null pragma Abstract_State. Refinement not
22405 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22407 if SPARK_Mode
/= Off
22409 (No
(Abstract_States
(Spec_Id
))
22410 or else Has_Null_Abstract_State
(Spec_Id
))
22413 ("useless refinement, package & does not define abstract "
22414 & "states", N
, Spec_Id
);
22419 -----------------------
22420 -- Relative_Deadline --
22421 -----------------------
22423 -- pragma Relative_Deadline (time_span_EXPRESSION);
22425 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
22426 P
: constant Node_Id
:= Parent
(N
);
22431 Check_No_Identifiers
;
22432 Check_Arg_Count
(1);
22434 Arg
:= Get_Pragma_Arg
(Arg1
);
22436 -- The expression must be analyzed in the special manner described
22437 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22439 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
22443 if Nkind
(P
) = N_Subprogram_Body
then
22444 Check_In_Main_Program
;
22446 -- Only Task and subprogram cases allowed
22448 elsif Nkind
(P
) /= N_Task_Definition
then
22452 -- Check duplicate pragma before we set the corresponding flag
22454 if Has_Relative_Deadline_Pragma
(P
) then
22455 Error_Pragma
("duplicate pragma% not allowed");
22458 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22459 -- Relative_Deadline pragma node cannot be inserted in the Rep
22460 -- Item chain of Ent since it is rewritten by the expander as a
22461 -- procedure call statement that will break the chain.
22463 Set_Has_Relative_Deadline_Pragma
(P
);
22464 end Relative_Deadline
;
22466 ------------------------
22467 -- Remote_Access_Type --
22468 ------------------------
22470 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22472 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
22477 Check_Arg_Count
(1);
22478 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22479 Check_Arg_Is_Local_Name
(Arg1
);
22481 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
22483 -- A pragma that applies to a Ghost entity becomes Ghost for the
22484 -- purposes of legality checks and removal of ignored Ghost code.
22486 Mark_Ghost_Pragma
(N
, E
);
22488 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
22489 and then Ekind
(E
) = E_General_Access_Type
22490 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
22491 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
22493 and then Is_Valid_Remote_Object_Type
22494 (Root_Type
(Directly_Designated_Type
(E
)))
22496 Set_Is_Remote_Types
(E
);
22500 ("pragma% applies only to formal access-to-class-wide types",
22503 end Remote_Access_Type
;
22505 ---------------------------
22506 -- Remote_Call_Interface --
22507 ---------------------------
22509 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22511 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
22512 Cunit_Node
: Node_Id
;
22513 Cunit_Ent
: Entity_Id
;
22517 Check_Ada_83_Warning
;
22518 Check_Valid_Library_Unit_Pragma
;
22520 if Nkind
(N
) = N_Null_Statement
then
22524 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22525 K
:= Nkind
(Unit
(Cunit_Node
));
22526 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22528 -- A pragma that applies to a Ghost entity becomes Ghost for the
22529 -- purposes of legality checks and removal of ignored Ghost code.
22531 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22533 if K
= N_Package_Declaration
22534 or else K
= N_Generic_Package_Declaration
22535 or else K
= N_Subprogram_Declaration
22536 or else K
= N_Generic_Subprogram_Declaration
22537 or else (K
= N_Subprogram_Body
22538 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
22543 "pragma% must apply to package or subprogram declaration");
22546 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
22547 end Remote_Call_Interface
;
22553 -- pragma Remote_Types [(library_unit_NAME)];
22555 when Pragma_Remote_Types
=> Remote_Types
: declare
22556 Cunit_Node
: Node_Id
;
22557 Cunit_Ent
: Entity_Id
;
22560 Check_Ada_83_Warning
;
22561 Check_Valid_Library_Unit_Pragma
;
22563 if Nkind
(N
) = N_Null_Statement
then
22567 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22568 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22570 -- A pragma that applies to a Ghost entity becomes Ghost for the
22571 -- purposes of legality checks and removal of ignored Ghost code.
22573 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22575 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22576 N_Generic_Package_Declaration
)
22579 ("pragma% can only apply to a package declaration");
22582 Set_Is_Remote_Types
(Cunit_Ent
);
22589 -- pragma Ravenscar;
22591 when Pragma_Ravenscar
=>
22593 Check_Arg_Count
(0);
22594 Check_Valid_Configuration_Pragma
;
22595 Set_Ravenscar_Profile
(Ravenscar
, N
);
22597 if Warn_On_Obsolescent_Feature
then
22599 ("pragma Ravenscar is an obsolescent feature?j?", N
);
22601 ("|use pragma Profile (Ravenscar) instead?j?", N
);
22604 -------------------------
22605 -- Restricted_Run_Time --
22606 -------------------------
22608 -- pragma Restricted_Run_Time;
22610 when Pragma_Restricted_Run_Time
=>
22612 Check_Arg_Count
(0);
22613 Check_Valid_Configuration_Pragma
;
22614 Set_Profile_Restrictions
22615 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
22617 if Warn_On_Obsolescent_Feature
then
22619 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22622 ("|use pragma Profile (Restricted) instead?j?", N
);
22629 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22632 -- restriction_IDENTIFIER
22633 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22635 when Pragma_Restrictions
=>
22636 Process_Restrictions_Or_Restriction_Warnings
22637 (Warn
=> Treat_Restrictions_As_Warnings
);
22639 --------------------------
22640 -- Restriction_Warnings --
22641 --------------------------
22643 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22646 -- restriction_IDENTIFIER
22647 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22649 when Pragma_Restriction_Warnings
=>
22651 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
22657 -- pragma Reviewable;
22659 when Pragma_Reviewable
=>
22660 Check_Ada_83_Warning
;
22661 Check_Arg_Count
(0);
22663 -- Call dummy debugging function rv. This is done to assist front
22664 -- end debugging. By placing a Reviewable pragma in the source
22665 -- program, a breakpoint on rv catches this place in the source,
22666 -- allowing convenient stepping to the point of interest.
22670 --------------------------
22671 -- Secondary_Stack_Size --
22672 --------------------------
22674 -- pragma Secondary_Stack_Size (EXPRESSION);
22676 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
22677 P
: constant Node_Id
:= Parent
(N
);
22683 Check_No_Identifiers
;
22684 Check_Arg_Count
(1);
22686 if Nkind
(P
) = N_Task_Definition
then
22687 Arg
:= Get_Pragma_Arg
(Arg1
);
22688 Ent
:= Defining_Identifier
(Parent
(P
));
22690 -- The expression must be analyzed in the special manner
22691 -- described in "Handling of Default Expressions" in sem.ads.
22693 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22695 -- The pragma cannot appear if the No_Secondary_Stack
22696 -- restriction is in effect.
22698 Check_Restriction
(No_Secondary_Stack
, Arg
);
22700 -- Anything else is incorrect
22706 -- Check duplicate pragma before we chain the pragma in the Rep
22707 -- Item chain of Ent.
22709 Check_Duplicate_Pragma
(Ent
);
22710 Record_Rep_Item
(Ent
, N
);
22711 end Secondary_Stack_Size
;
22713 --------------------------
22714 -- Short_Circuit_And_Or --
22715 --------------------------
22717 -- pragma Short_Circuit_And_Or;
22719 when Pragma_Short_Circuit_And_Or
=>
22721 Check_Arg_Count
(0);
22722 Check_Valid_Configuration_Pragma
;
22723 Short_Circuit_And_Or
:= True;
22725 -------------------
22726 -- Share_Generic --
22727 -------------------
22729 -- pragma Share_Generic (GNAME {, GNAME});
22731 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22733 when Pragma_Share_Generic
=>
22735 Process_Generic_List
;
22741 -- pragma Shared (LOCAL_NAME);
22743 when Pragma_Shared
=>
22745 Process_Atomic_Independent_Shared_Volatile
;
22747 --------------------
22748 -- Shared_Passive --
22749 --------------------
22751 -- pragma Shared_Passive [(library_unit_NAME)];
22753 -- Set the flag Is_Shared_Passive of program unit name entity
22755 when Pragma_Shared_Passive
=> Shared_Passive
: declare
22756 Cunit_Node
: Node_Id
;
22757 Cunit_Ent
: Entity_Id
;
22760 Check_Ada_83_Warning
;
22761 Check_Valid_Library_Unit_Pragma
;
22763 if Nkind
(N
) = N_Null_Statement
then
22767 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22768 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22770 -- A pragma that applies to a Ghost entity becomes Ghost for the
22771 -- purposes of legality checks and removal of ignored Ghost code.
22773 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22775 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22776 N_Generic_Package_Declaration
)
22779 ("pragma% can only apply to a package declaration");
22782 Set_Is_Shared_Passive
(Cunit_Ent
);
22783 end Shared_Passive
;
22785 -----------------------
22786 -- Short_Descriptors --
22787 -----------------------
22789 -- pragma Short_Descriptors;
22791 -- Recognize and validate, but otherwise ignore
22793 when Pragma_Short_Descriptors
=>
22795 Check_Arg_Count
(0);
22796 Check_Valid_Configuration_Pragma
;
22798 ------------------------------
22799 -- Simple_Storage_Pool_Type --
22800 ------------------------------
22802 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22804 when Pragma_Simple_Storage_Pool_Type
=>
22805 Simple_Storage_Pool_Type
: declare
22811 Check_Arg_Count
(1);
22812 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22814 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22815 Find_Type
(Type_Id
);
22816 Typ
:= Entity
(Type_Id
);
22818 if Typ
= Any_Type
then
22822 -- A pragma that applies to a Ghost entity becomes Ghost for the
22823 -- purposes of legality checks and removal of ignored Ghost code.
22825 Mark_Ghost_Pragma
(N
, Typ
);
22827 -- We require the pragma to apply to a type declared in a package
22828 -- declaration, but not (immediately) within a package body.
22830 if Ekind
(Current_Scope
) /= E_Package
22831 or else In_Package_Body
(Current_Scope
)
22834 ("pragma% can only apply to type declared immediately "
22835 & "within a package declaration");
22838 -- A simple storage pool type must be an immutably limited record
22839 -- or private type. If the pragma is given for a private type,
22840 -- the full type is similarly restricted (which is checked later
22841 -- in Freeze_Entity).
22843 if Is_Record_Type
(Typ
)
22844 and then not Is_Limited_View
(Typ
)
22847 ("pragma% can only apply to explicitly limited record type");
22849 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
22851 ("pragma% can only apply to a private type that is limited");
22853 elsif not Is_Record_Type
(Typ
)
22854 and then not Is_Private_Type
(Typ
)
22857 ("pragma% can only apply to limited record or private type");
22860 Record_Rep_Item
(Typ
, N
);
22861 end Simple_Storage_Pool_Type
;
22863 ----------------------
22864 -- Source_File_Name --
22865 ----------------------
22867 -- There are five forms for this pragma:
22869 -- pragma Source_File_Name (
22870 -- [UNIT_NAME =>] unit_NAME,
22871 -- BODY_FILE_NAME => STRING_LITERAL
22872 -- [, [INDEX =>] INTEGER_LITERAL]);
22874 -- pragma Source_File_Name (
22875 -- [UNIT_NAME =>] unit_NAME,
22876 -- SPEC_FILE_NAME => STRING_LITERAL
22877 -- [, [INDEX =>] INTEGER_LITERAL]);
22879 -- pragma Source_File_Name (
22880 -- BODY_FILE_NAME => STRING_LITERAL
22881 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22882 -- [, CASING => CASING_SPEC]);
22884 -- pragma Source_File_Name (
22885 -- SPEC_FILE_NAME => STRING_LITERAL
22886 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22887 -- [, CASING => CASING_SPEC]);
22889 -- pragma Source_File_Name (
22890 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22891 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22892 -- [, CASING => CASING_SPEC]);
22894 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22896 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22897 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22898 -- only be used when no project file is used, while SFNP can only be
22899 -- used when a project file is used.
22901 -- No processing here. Processing was completed during parsing, since
22902 -- we need to have file names set as early as possible. Units are
22903 -- loaded well before semantic processing starts.
22905 -- The only processing we defer to this point is the check for
22906 -- correct placement.
22908 when Pragma_Source_File_Name
=>
22910 Check_Valid_Configuration_Pragma
;
22912 ------------------------------
22913 -- Source_File_Name_Project --
22914 ------------------------------
22916 -- See Source_File_Name for syntax
22918 -- No processing here. Processing was completed during parsing, since
22919 -- we need to have file names set as early as possible. Units are
22920 -- loaded well before semantic processing starts.
22922 -- The only processing we defer to this point is the check for
22923 -- correct placement.
22925 when Pragma_Source_File_Name_Project
=>
22927 Check_Valid_Configuration_Pragma
;
22929 -- Check that a pragma Source_File_Name_Project is used only in a
22930 -- configuration pragmas file.
22932 -- Pragmas Source_File_Name_Project should only be generated by
22933 -- the Project Manager in configuration pragmas files.
22935 -- This is really an ugly test. It seems to depend on some
22936 -- accidental and undocumented property. At the very least it
22937 -- needs to be documented, but it would be better to have a
22938 -- clean way of testing if we are in a configuration file???
22940 if Present
(Parent
(N
)) then
22942 ("pragma% can only appear in a configuration pragmas file");
22945 ----------------------
22946 -- Source_Reference --
22947 ----------------------
22949 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22951 -- Nothing to do, all processing completed in Par.Prag, since we need
22952 -- the information for possible parser messages that are output.
22954 when Pragma_Source_Reference
=>
22961 -- pragma SPARK_Mode [(On | Off)];
22963 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
22964 Mode_Id
: SPARK_Mode_Type
;
22966 procedure Check_Pragma_Conformance
22967 (Context_Pragma
: Node_Id
;
22968 Entity
: Entity_Id
;
22969 Entity_Pragma
: Node_Id
);
22970 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22971 -- conformance of pragma N depending the following scenarios:
22973 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22974 -- compatible with the pragma Context_Pragma that was inherited
22975 -- from the context:
22976 -- * If the mode of Context_Pragma is ON, then the new mode can
22978 -- * If the mode of Context_Pragma is OFF, then the only allowed
22979 -- new mode is also OFF. Emit error if this is not the case.
22981 -- If Entity is not Empty, verify that pragma N is compatible with
22982 -- pragma Entity_Pragma that belongs to Entity.
22983 -- * If Entity_Pragma is Empty, always issue an error as this
22984 -- corresponds to the case where a previous section of Entity
22985 -- has no SPARK_Mode set.
22986 -- * If the mode of Entity_Pragma is ON, then the new mode can
22988 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22989 -- new mode is also OFF. Emit error if this is not the case.
22991 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
22992 -- Subsidiary to routines Process_xxx. Verify that the related
22993 -- entity E subject to pragma SPARK_Mode is library-level.
22995 procedure Process_Body
(Decl
: Node_Id
);
22996 -- Verify the legality of pragma SPARK_Mode when it appears as the
22997 -- top of the body declarations of entry, package, protected unit,
22998 -- subprogram or task unit body denoted by Decl.
23000 procedure Process_Overloadable
(Decl
: Node_Id
);
23001 -- Verify the legality of pragma SPARK_Mode when it applies to an
23002 -- entry or [generic] subprogram declaration denoted by Decl.
23004 procedure Process_Private_Part
(Decl
: Node_Id
);
23005 -- Verify the legality of pragma SPARK_Mode when it appears at the
23006 -- top of the private declarations of a package spec, protected or
23007 -- task unit declaration denoted by Decl.
23009 procedure Process_Statement_Part
(Decl
: Node_Id
);
23010 -- Verify the legality of pragma SPARK_Mode when it appears at the
23011 -- top of the statement sequence of a package body denoted by node
23014 procedure Process_Visible_Part
(Decl
: Node_Id
);
23015 -- Verify the legality of pragma SPARK_Mode when it appears at the
23016 -- top of the visible declarations of a package spec, protected or
23017 -- task unit declaration denoted by Decl. The routine is also used
23018 -- on protected or task units declared without a definition.
23020 procedure Set_SPARK_Context
;
23021 -- Subsidiary to routines Process_xxx. Set the global variables
23022 -- which represent the mode of the context from pragma N. Ensure
23023 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23025 ------------------------------
23026 -- Check_Pragma_Conformance --
23027 ------------------------------
23029 procedure Check_Pragma_Conformance
23030 (Context_Pragma
: Node_Id
;
23031 Entity
: Entity_Id
;
23032 Entity_Pragma
: Node_Id
)
23034 Err_Id
: Entity_Id
;
23038 -- The current pragma may appear without an argument. If this
23039 -- is the case, associate all error messages with the pragma
23042 if Present
(Arg1
) then
23048 -- The mode of the current pragma is compared against that of
23049 -- an enclosing context.
23051 if Present
(Context_Pragma
) then
23052 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
23054 -- Issue an error if the new mode is less restrictive than
23055 -- that of the context.
23057 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
23058 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23061 ("cannot change SPARK_Mode from Off to On", Err_N
);
23062 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
23063 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
23068 -- The mode of the current pragma is compared against that of
23069 -- an initial package, protected type, subprogram or task type
23072 if Present
(Entity
) then
23074 -- A simple protected or task type is transformed into an
23075 -- anonymous type whose name cannot be used to issue error
23076 -- messages. Recover the original entity of the type.
23078 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
23081 (Original_Node
(Unit_Declaration_Node
(Entity
)));
23086 -- Both the initial declaration and the completion carry
23087 -- SPARK_Mode pragmas.
23089 if Present
(Entity_Pragma
) then
23090 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
23092 -- Issue an error if the new mode is less restrictive
23093 -- than that of the initial declaration.
23095 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
23096 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23098 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23099 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
23101 ("\value Off was set for SPARK_Mode on&#",
23106 -- Otherwise the initial declaration lacks a SPARK_Mode
23107 -- pragma in which case the current pragma is illegal as
23108 -- it cannot "complete".
23111 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23112 Error_Msg_Sloc
:= Sloc
(Err_Id
);
23114 ("\no value was set for SPARK_Mode on&#",
23119 end Check_Pragma_Conformance
;
23121 --------------------------------
23122 -- Check_Library_Level_Entity --
23123 --------------------------------
23125 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
23126 procedure Add_Entity_To_Name_Buffer
;
23127 -- Add the E_Kind of entity E to the name buffer
23129 -------------------------------
23130 -- Add_Entity_To_Name_Buffer --
23131 -------------------------------
23133 procedure Add_Entity_To_Name_Buffer
is
23135 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
23136 Add_Str_To_Name_Buffer
("entry");
23138 elsif Ekind_In
(E
, E_Generic_Package
,
23142 Add_Str_To_Name_Buffer
("package");
23144 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
23145 Add_Str_To_Name_Buffer
("protected type");
23147 elsif Ekind_In
(E
, E_Function
,
23148 E_Generic_Function
,
23149 E_Generic_Procedure
,
23153 Add_Str_To_Name_Buffer
("subprogram");
23156 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
23157 Add_Str_To_Name_Buffer
("task type");
23159 end Add_Entity_To_Name_Buffer
;
23163 Msg_1
: constant String := "incorrect placement of pragma%";
23166 -- Start of processing for Check_Library_Level_Entity
23169 if not Is_Library_Level_Entity
(E
) then
23170 Error_Msg_Name_1
:= Pname
;
23171 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
23174 Add_Str_To_Name_Buffer
("\& is not a library-level ");
23175 Add_Entity_To_Name_Buffer
;
23177 Msg_2
:= Name_Find
;
23178 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
23182 end Check_Library_Level_Entity
;
23188 procedure Process_Body
(Decl
: Node_Id
) is
23189 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23190 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
23193 -- Ignore pragma when applied to the special body created for
23194 -- inlining, recognized by its internal name _Parent.
23196 if Chars
(Body_Id
) = Name_uParent
then
23200 Check_Library_Level_Entity
(Body_Id
);
23202 -- For entry bodies, verify the legality against:
23203 -- * The mode of the context
23204 -- * The mode of the spec (if any)
23206 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
23208 -- A stand-alone subprogram body
23210 if Body_Id
= Spec_Id
then
23211 Check_Pragma_Conformance
23212 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23214 Entity_Pragma
=> Empty
);
23216 -- An entry or subprogram body that completes a previous
23220 Check_Pragma_Conformance
23221 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23223 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23227 Set_SPARK_Pragma
(Body_Id
, N
);
23228 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23230 -- For package bodies, verify the legality against:
23231 -- * The mode of the context
23232 -- * The mode of the private part
23234 -- This case is separated from protected and task bodies
23235 -- because the statement part of the package body inherits
23236 -- the mode of the body declarations.
23238 elsif Nkind
(Decl
) = N_Package_Body
then
23239 Check_Pragma_Conformance
23240 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23242 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23245 Set_SPARK_Pragma
(Body_Id
, N
);
23246 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23247 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23248 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
23250 -- For protected and task bodies, verify the legality against:
23251 -- * The mode of the context
23252 -- * The mode of the private part
23256 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
23258 Check_Pragma_Conformance
23259 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23261 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23264 Set_SPARK_Pragma
(Body_Id
, N
);
23265 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23269 --------------------------
23270 -- Process_Overloadable --
23271 --------------------------
23273 procedure Process_Overloadable
(Decl
: Node_Id
) is
23274 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23275 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
23278 Check_Library_Level_Entity
(Spec_Id
);
23280 -- Verify the legality against:
23281 -- * The mode of the context
23283 Check_Pragma_Conformance
23284 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23286 Entity_Pragma
=> Empty
);
23288 Set_SPARK_Pragma
(Spec_Id
, N
);
23289 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23291 -- When the pragma applies to the anonymous object created for
23292 -- a single task type, decorate the type as well. This scenario
23293 -- arises when the single task type lacks a task definition,
23294 -- therefore there is no issue with respect to a potential
23295 -- pragma SPARK_Mode in the private part.
23297 -- task type Anon_Task_Typ;
23298 -- Obj : Anon_Task_Typ;
23299 -- pragma SPARK_Mode ...;
23301 if Is_Single_Task_Object
(Spec_Id
) then
23302 Set_SPARK_Pragma
(Spec_Typ
, N
);
23303 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
23304 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
23305 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
23307 end Process_Overloadable
;
23309 --------------------------
23310 -- Process_Private_Part --
23311 --------------------------
23313 procedure Process_Private_Part
(Decl
: Node_Id
) is
23314 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23317 Check_Library_Level_Entity
(Spec_Id
);
23319 -- Verify the legality against:
23320 -- * The mode of the visible declarations
23322 Check_Pragma_Conformance
23323 (Context_Pragma
=> Empty
,
23325 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23328 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23329 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
23330 end Process_Private_Part
;
23332 ----------------------------
23333 -- Process_Statement_Part --
23334 ----------------------------
23336 procedure Process_Statement_Part
(Decl
: Node_Id
) is
23337 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23340 Check_Library_Level_Entity
(Body_Id
);
23342 -- Verify the legality against:
23343 -- * The mode of the body declarations
23345 Check_Pragma_Conformance
23346 (Context_Pragma
=> Empty
,
23348 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
23351 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23352 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
23353 end Process_Statement_Part
;
23355 --------------------------
23356 -- Process_Visible_Part --
23357 --------------------------
23359 procedure Process_Visible_Part
(Decl
: Node_Id
) is
23360 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23361 Obj_Id
: Entity_Id
;
23364 Check_Library_Level_Entity
(Spec_Id
);
23366 -- Verify the legality against:
23367 -- * The mode of the context
23369 Check_Pragma_Conformance
23370 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23372 Entity_Pragma
=> Empty
);
23374 -- A task unit declared without a definition does not set the
23375 -- SPARK_Mode of the context because the task does not have any
23376 -- entries that could inherit the mode.
23378 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
23379 N_Task_Type_Declaration
)
23384 Set_SPARK_Pragma
(Spec_Id
, N
);
23385 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23386 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23387 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
23389 -- When the pragma applies to a single protected or task type,
23390 -- decorate the corresponding anonymous object as well.
23392 -- protected Anon_Prot_Typ is
23393 -- pragma SPARK_Mode ...;
23395 -- end Anon_Prot_Typ;
23397 -- Obj : Anon_Prot_Typ;
23399 if Is_Single_Concurrent_Type
(Spec_Id
) then
23400 Obj_Id
:= Anonymous_Object
(Spec_Id
);
23402 Set_SPARK_Pragma
(Obj_Id
, N
);
23403 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
23405 end Process_Visible_Part
;
23407 -----------------------
23408 -- Set_SPARK_Context --
23409 -----------------------
23411 procedure Set_SPARK_Context
is
23413 SPARK_Mode
:= Mode_Id
;
23414 SPARK_Mode_Pragma
:= N
;
23415 end Set_SPARK_Context
;
23423 -- Start of processing for Do_SPARK_Mode
23426 -- When a SPARK_Mode pragma appears inside an instantiation whose
23427 -- enclosing context has SPARK_Mode set to "off", the pragma has
23428 -- no semantic effect.
23430 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
23431 Rewrite
(N
, Make_Null_Statement
(Loc
));
23437 Check_No_Identifiers
;
23438 Check_At_Most_N_Arguments
(1);
23440 -- Check the legality of the mode (no argument = ON)
23442 if Arg_Count
= 1 then
23443 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23444 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
23449 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
23450 Context
:= Parent
(N
);
23452 -- The pragma appears in a configuration file
23454 if No
(Context
) then
23455 Check_Valid_Configuration_Pragma
;
23457 if Present
(SPARK_Mode_Pragma
) then
23460 Prev
=> SPARK_Mode_Pragma
);
23466 -- The pragma acts as a configuration pragma in a compilation unit
23468 -- pragma SPARK_Mode ...;
23469 -- package Pack is ...;
23471 elsif Nkind
(Context
) = N_Compilation_Unit
23472 and then List_Containing
(N
) = Context_Items
(Context
)
23474 Check_Valid_Configuration_Pragma
;
23477 -- Otherwise the placement of the pragma within the tree dictates
23478 -- its associated construct. Inspect the declarative list where
23479 -- the pragma resides to find a potential construct.
23483 while Present
(Stmt
) loop
23485 -- Skip prior pragmas, but check for duplicates. Note that
23486 -- this also takes care of pragmas generated for aspects.
23488 if Nkind
(Stmt
) = N_Pragma
then
23489 if Pragma_Name
(Stmt
) = Pname
then
23496 -- The pragma applies to an expression function that has
23497 -- already been rewritten into a subprogram declaration.
23499 -- function Expr_Func return ... is (...);
23500 -- pragma SPARK_Mode ...;
23502 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
23503 and then Nkind
(Original_Node
(Stmt
)) =
23504 N_Expression_Function
23506 Process_Overloadable
(Stmt
);
23509 -- The pragma applies to the anonymous object created for a
23510 -- single concurrent type.
23512 -- protected type Anon_Prot_Typ ...;
23513 -- Obj : Anon_Prot_Typ;
23514 -- pragma SPARK_Mode ...;
23516 elsif Nkind
(Stmt
) = N_Object_Declaration
23517 and then Is_Single_Concurrent_Object
23518 (Defining_Entity
(Stmt
))
23520 Process_Overloadable
(Stmt
);
23523 -- Skip internally generated code
23525 elsif not Comes_From_Source
(Stmt
) then
23528 -- The pragma applies to an entry or [generic] subprogram
23532 -- pragma SPARK_Mode ...;
23535 -- procedure Proc ...;
23536 -- pragma SPARK_Mode ...;
23538 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
23539 N_Subprogram_Declaration
)
23540 or else (Nkind
(Stmt
) = N_Entry_Declaration
23541 and then Is_Protected_Type
23542 (Scope
(Defining_Entity
(Stmt
))))
23544 Process_Overloadable
(Stmt
);
23547 -- Otherwise the pragma does not apply to a legal construct
23548 -- or it does not appear at the top of a declarative or a
23549 -- statement list. Issue an error and stop the analysis.
23559 -- The pragma applies to a package or a subprogram that acts as
23560 -- a compilation unit.
23562 -- procedure Proc ...;
23563 -- pragma SPARK_Mode ...;
23565 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
23566 Context
:= Unit
(Parent
(Context
));
23569 -- The pragma appears at the top of entry, package, protected
23570 -- unit, subprogram or task unit body declarations.
23572 -- entry Ent when ... is
23573 -- pragma SPARK_Mode ...;
23575 -- package body Pack is
23576 -- pragma SPARK_Mode ...;
23578 -- procedure Proc ... is
23579 -- pragma SPARK_Mode;
23581 -- protected body Prot is
23582 -- pragma SPARK_Mode ...;
23584 if Nkind_In
(Context
, N_Entry_Body
,
23590 Process_Body
(Context
);
23592 -- The pragma appears at the top of the visible or private
23593 -- declaration of a package spec, protected or task unit.
23596 -- pragma SPARK_Mode ...;
23598 -- pragma SPARK_Mode ...;
23600 -- protected [type] Prot is
23601 -- pragma SPARK_Mode ...;
23603 -- pragma SPARK_Mode ...;
23605 elsif Nkind_In
(Context
, N_Package_Specification
,
23606 N_Protected_Definition
,
23609 if List_Containing
(N
) = Visible_Declarations
(Context
) then
23610 Process_Visible_Part
(Parent
(Context
));
23612 Process_Private_Part
(Parent
(Context
));
23615 -- The pragma appears at the top of package body statements
23617 -- package body Pack is
23619 -- pragma SPARK_Mode;
23621 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
23622 and then Nkind
(Parent
(Context
)) = N_Package_Body
23624 Process_Statement_Part
(Parent
(Context
));
23626 -- The pragma appeared as an aspect of a [generic] subprogram
23627 -- declaration that acts as a compilation unit.
23630 -- procedure Proc ...;
23631 -- pragma SPARK_Mode ...;
23633 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
23634 N_Subprogram_Declaration
)
23636 Process_Overloadable
(Context
);
23638 -- The pragma does not apply to a legal construct, issue error
23646 --------------------------------
23647 -- Static_Elaboration_Desired --
23648 --------------------------------
23650 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23652 when Pragma_Static_Elaboration_Desired
=>
23654 Check_At_Most_N_Arguments
(1);
23656 if Is_Compilation_Unit
(Current_Scope
)
23657 and then Ekind
(Current_Scope
) = E_Package
23659 Set_Static_Elaboration_Desired
(Current_Scope
, True);
23661 Error_Pragma
("pragma% must apply to a library-level package");
23668 -- pragma Storage_Size (EXPRESSION);
23670 when Pragma_Storage_Size
=> Storage_Size
: declare
23671 P
: constant Node_Id
:= Parent
(N
);
23675 Check_No_Identifiers
;
23676 Check_Arg_Count
(1);
23678 -- The expression must be analyzed in the special manner described
23679 -- in "Handling of Default Expressions" in sem.ads.
23681 Arg
:= Get_Pragma_Arg
(Arg1
);
23682 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23684 if not Is_OK_Static_Expression
(Arg
) then
23685 Check_Restriction
(Static_Storage_Size
, Arg
);
23688 if Nkind
(P
) /= N_Task_Definition
then
23693 if Has_Storage_Size_Pragma
(P
) then
23694 Error_Pragma
("duplicate pragma% not allowed");
23696 Set_Has_Storage_Size_Pragma
(P
, True);
23699 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
23707 -- pragma Storage_Unit (NUMERIC_LITERAL);
23709 -- Only permitted argument is System'Storage_Unit value
23711 when Pragma_Storage_Unit
=>
23712 Check_No_Identifiers
;
23713 Check_Arg_Count
(1);
23714 Check_Arg_Is_Integer_Literal
(Arg1
);
23716 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
23717 UI_From_Int
(Ttypes
.System_Storage_Unit
)
23719 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
23721 ("the only allowed argument for pragma% is ^", Arg1
);
23724 --------------------
23725 -- Stream_Convert --
23726 --------------------
23728 -- pragma Stream_Convert (
23729 -- [Entity =>] type_LOCAL_NAME,
23730 -- [Read =>] function_NAME,
23731 -- [Write =>] function NAME);
23733 when Pragma_Stream_Convert
=> Stream_Convert
: declare
23734 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
23735 -- Check that the given argument is the name of a local function
23736 -- of one argument that is not overloaded earlier in the current
23737 -- local scope. A check is also made that the argument is a
23738 -- function with one parameter.
23740 --------------------------------------
23741 -- Check_OK_Stream_Convert_Function --
23742 --------------------------------------
23744 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
23748 Check_Arg_Is_Local_Name
(Arg
);
23749 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
23751 if Has_Homonym
(Ent
) then
23753 ("argument for pragma% may not be overloaded", Arg
);
23756 if Ekind
(Ent
) /= E_Function
23757 or else No
(First_Formal
(Ent
))
23758 or else Present
(Next_Formal
(First_Formal
(Ent
)))
23761 ("argument for pragma% must be function of one argument",
23764 end Check_OK_Stream_Convert_Function
;
23766 -- Start of processing for Stream_Convert
23770 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
23771 Check_Arg_Count
(3);
23772 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23773 Check_Optional_Identifier
(Arg2
, Name_Read
);
23774 Check_Optional_Identifier
(Arg3
, Name_Write
);
23775 Check_Arg_Is_Local_Name
(Arg1
);
23776 Check_OK_Stream_Convert_Function
(Arg2
);
23777 Check_OK_Stream_Convert_Function
(Arg3
);
23780 Typ
: constant Entity_Id
:=
23781 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
23782 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
23783 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
23786 Check_First_Subtype
(Arg1
);
23788 -- Check for too early or too late. Note that we don't enforce
23789 -- the rule about primitive operations in this case, since, as
23790 -- is the case for explicit stream attributes themselves, these
23791 -- restrictions are not appropriate. Note that the chaining of
23792 -- the pragma by Rep_Item_Too_Late is actually the critical
23793 -- processing done for this pragma.
23795 if Rep_Item_Too_Early
(Typ
, N
)
23797 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
23802 -- Return if previous error
23804 if Etype
(Typ
) = Any_Type
23806 Etype
(Read
) = Any_Type
23808 Etype
(Write
) = Any_Type
23815 if Underlying_Type
(Etype
(Read
)) /= Typ
then
23817 ("incorrect return type for function&", Arg2
);
23820 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
23822 ("incorrect parameter type for function&", Arg3
);
23825 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
23826 Underlying_Type
(Etype
(Write
))
23829 ("result type of & does not match Read parameter type",
23833 end Stream_Convert
;
23839 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23841 -- This is processed by the parser since some of the style checks
23842 -- take place during source scanning and parsing. This means that
23843 -- we don't need to issue error messages here.
23845 when Pragma_Style_Checks
=> Style_Checks
: declare
23846 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23852 Check_No_Identifiers
;
23854 -- Two argument form
23856 if Arg_Count
= 2 then
23857 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23864 E_Id
:= Get_Pragma_Arg
(Arg2
);
23867 if not Is_Entity_Name
(E_Id
) then
23869 ("second argument of pragma% must be entity name",
23873 E
:= Entity
(E_Id
);
23875 if not Ignore_Style_Checks_Pragmas
then
23880 Set_Suppress_Style_Checks
23881 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
23882 exit when No
(Homonym
(E
));
23889 -- One argument form
23892 Check_Arg_Count
(1);
23894 if Nkind
(A
) = N_String_Literal
then
23898 Slen
: constant Natural := Natural (String_Length
(S
));
23899 Options
: String (1 .. Slen
);
23905 C
:= Get_String_Char
(S
, Pos
(J
));
23906 exit when not In_Character_Range
(C
);
23907 Options
(J
) := Get_Character
(C
);
23909 -- If at end of string, set options. As per discussion
23910 -- above, no need to check for errors, since we issued
23911 -- them in the parser.
23914 if not Ignore_Style_Checks_Pragmas
then
23915 Set_Style_Check_Options
(Options
);
23925 elsif Nkind
(A
) = N_Identifier
then
23926 if Chars
(A
) = Name_All_Checks
then
23927 if not Ignore_Style_Checks_Pragmas
then
23929 Set_GNAT_Style_Check_Options
;
23931 Set_Default_Style_Check_Options
;
23935 elsif Chars
(A
) = Name_On
then
23936 if not Ignore_Style_Checks_Pragmas
then
23937 Style_Check
:= True;
23940 elsif Chars
(A
) = Name_Off
then
23941 if not Ignore_Style_Checks_Pragmas
then
23942 Style_Check
:= False;
23953 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23955 when Pragma_Subtitle
=>
23957 Check_Arg_Count
(1);
23958 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
23959 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23966 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23968 when Pragma_Suppress
=>
23969 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
23975 -- pragma Suppress_All;
23977 -- The only check made here is that the pragma has no arguments.
23978 -- There are no placement rules, and the processing required (setting
23979 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23980 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23981 -- then creates and inserts a pragma Suppress (All_Checks).
23983 when Pragma_Suppress_All
=>
23985 Check_Arg_Count
(0);
23987 -------------------------
23988 -- Suppress_Debug_Info --
23989 -------------------------
23991 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23993 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
23994 Nam_Id
: Entity_Id
;
23998 Check_Arg_Count
(1);
23999 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24000 Check_Arg_Is_Local_Name
(Arg1
);
24002 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
24004 -- A pragma that applies to a Ghost entity becomes Ghost for the
24005 -- purposes of legality checks and removal of ignored Ghost code.
24007 Mark_Ghost_Pragma
(N
, Nam_Id
);
24008 Set_Debug_Info_Off
(Nam_Id
);
24009 end Suppress_Debug_Info
;
24011 ----------------------------------
24012 -- Suppress_Exception_Locations --
24013 ----------------------------------
24015 -- pragma Suppress_Exception_Locations;
24017 when Pragma_Suppress_Exception_Locations
=>
24019 Check_Arg_Count
(0);
24020 Check_Valid_Configuration_Pragma
;
24021 Exception_Locations_Suppressed
:= True;
24023 -----------------------------
24024 -- Suppress_Initialization --
24025 -----------------------------
24027 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24029 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
24035 Check_Arg_Count
(1);
24036 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24037 Check_Arg_Is_Local_Name
(Arg1
);
24039 E_Id
:= Get_Pragma_Arg
(Arg1
);
24041 if Etype
(E_Id
) = Any_Type
then
24045 E
:= Entity
(E_Id
);
24047 -- A pragma that applies to a Ghost entity becomes Ghost for the
24048 -- purposes of legality checks and removal of ignored Ghost code.
24050 Mark_Ghost_Pragma
(N
, E
);
24052 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
24054 ("pragma% requires variable, type or subtype", Arg1
);
24057 if Rep_Item_Too_Early
(E
, N
)
24059 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
24064 -- For incomplete/private type, set flag on full view
24066 if Is_Incomplete_Or_Private_Type
(E
) then
24067 if No
(Full_View
(Base_Type
(E
))) then
24069 ("argument of pragma% cannot be an incomplete type", Arg1
);
24071 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
24074 -- For first subtype, set flag on base type
24076 elsif Is_First_Subtype
(E
) then
24077 Set_Suppress_Initialization
(Base_Type
(E
));
24079 -- For other than first subtype, set flag on subtype or variable
24082 Set_Suppress_Initialization
(E
);
24090 -- pragma System_Name (DIRECT_NAME);
24092 -- Syntax check: one argument, which must be the identifier GNAT or
24093 -- the identifier GCC, no other identifiers are acceptable.
24095 when Pragma_System_Name
=>
24097 Check_No_Identifiers
;
24098 Check_Arg_Count
(1);
24099 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
24101 -----------------------------
24102 -- Task_Dispatching_Policy --
24103 -----------------------------
24105 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24107 when Pragma_Task_Dispatching_Policy
=> declare
24111 Check_Ada_83_Warning
;
24112 Check_Arg_Count
(1);
24113 Check_No_Identifiers
;
24114 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
24115 Check_Valid_Configuration_Pragma
;
24116 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24117 DP
:= Fold_Upper
(Name_Buffer
(1));
24119 if Task_Dispatching_Policy
/= ' '
24120 and then Task_Dispatching_Policy
/= DP
24122 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
24124 ("task dispatching policy incompatible with policy#");
24126 -- Set new policy, but always preserve System_Location since we
24127 -- like the error message with the run time name.
24130 Task_Dispatching_Policy
:= DP
;
24132 if Task_Dispatching_Policy_Sloc
/= System_Location
then
24133 Task_Dispatching_Policy_Sloc
:= Loc
;
24142 -- pragma Task_Info (EXPRESSION);
24144 when Pragma_Task_Info
=> Task_Info
: declare
24145 P
: constant Node_Id
:= Parent
(N
);
24151 if Warn_On_Obsolescent_Feature
then
24153 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24154 & "instead?j?", N
);
24157 if Nkind
(P
) /= N_Task_Definition
then
24158 Error_Pragma
("pragma% must appear in task definition");
24161 Check_No_Identifiers
;
24162 Check_Arg_Count
(1);
24164 Analyze_And_Resolve
24165 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
24167 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
24171 Ent
:= Defining_Identifier
(Parent
(P
));
24173 -- Check duplicate pragma before we chain the pragma in the Rep
24174 -- Item chain of Ent.
24177 (Ent
, Name_Task_Info
, Check_Parents
=> False)
24179 Error_Pragma
("duplicate pragma% not allowed");
24182 Record_Rep_Item
(Ent
, N
);
24189 -- pragma Task_Name (string_EXPRESSION);
24191 when Pragma_Task_Name
=> Task_Name
: declare
24192 P
: constant Node_Id
:= Parent
(N
);
24197 Check_No_Identifiers
;
24198 Check_Arg_Count
(1);
24200 Arg
:= Get_Pragma_Arg
(Arg1
);
24202 -- The expression is used in the call to Create_Task, and must be
24203 -- expanded there, not in the context of the current spec. It must
24204 -- however be analyzed to capture global references, in case it
24205 -- appears in a generic context.
24207 Preanalyze_And_Resolve
(Arg
, Standard_String
);
24209 if Nkind
(P
) /= N_Task_Definition
then
24213 Ent
:= Defining_Identifier
(Parent
(P
));
24215 -- Check duplicate pragma before we chain the pragma in the Rep
24216 -- Item chain of Ent.
24219 (Ent
, Name_Task_Name
, Check_Parents
=> False)
24221 Error_Pragma
("duplicate pragma% not allowed");
24224 Record_Rep_Item
(Ent
, N
);
24231 -- pragma Task_Storage (
24232 -- [Task_Type =>] LOCAL_NAME,
24233 -- [Top_Guard =>] static_integer_EXPRESSION);
24235 when Pragma_Task_Storage
=> Task_Storage
: declare
24236 Args
: Args_List
(1 .. 2);
24237 Names
: constant Name_List
(1 .. 2) := (
24241 Task_Type
: Node_Id
renames Args
(1);
24242 Top_Guard
: Node_Id
renames Args
(2);
24248 Gather_Associations
(Names
, Args
);
24250 if No
(Task_Type
) then
24252 ("missing task_type argument for pragma%");
24255 Check_Arg_Is_Local_Name
(Task_Type
);
24257 Ent
:= Entity
(Task_Type
);
24259 if not Is_Task_Type
(Ent
) then
24261 ("argument for pragma% must be task type", Task_Type
);
24264 if No
(Top_Guard
) then
24266 ("pragma% takes two arguments", Task_Type
);
24268 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
24271 Check_First_Subtype
(Task_Type
);
24273 if Rep_Item_Too_Late
(Ent
, N
) then
24282 -- pragma Test_Case
24283 -- ([Name =>] Static_String_EXPRESSION
24284 -- ,[Mode =>] MODE_TYPE
24285 -- [, Requires => Boolean_EXPRESSION]
24286 -- [, Ensures => Boolean_EXPRESSION]);
24288 -- MODE_TYPE ::= Nominal | Robustness
24290 -- Characteristics:
24292 -- * Analysis - The annotation undergoes initial checks to verify
24293 -- the legal placement and context. Secondary checks preanalyze the
24296 -- Analyze_Test_Case_In_Decl_Part
24298 -- * Expansion - None.
24300 -- * Template - The annotation utilizes the generic template of the
24301 -- related subprogram when it is:
24303 -- aspect on subprogram declaration
24305 -- The annotation must prepare its own template when it is:
24307 -- pragma on subprogram declaration
24309 -- * Globals - Capture of global references must occur after full
24312 -- * Instance - The annotation is instantiated automatically when
24313 -- the related generic subprogram is instantiated except for the
24314 -- "pragma on subprogram declaration" case. In that scenario the
24315 -- annotation must instantiate itself.
24317 when Pragma_Test_Case
=> Test_Case
: declare
24318 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
24319 -- Ensure that the contract of subprogram Subp_Id does not contain
24320 -- another Test_Case pragma with the same Name as the current one.
24322 -------------------------
24323 -- Check_Distinct_Name --
24324 -------------------------
24326 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
24327 Items
: constant Node_Id
:= Contract
(Subp_Id
);
24328 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
24332 -- Inspect all Test_Case pragma of the related subprogram
24333 -- looking for one with a duplicate "Name" argument.
24335 if Present
(Items
) then
24336 Prag
:= Contract_Test_Cases
(Items
);
24337 while Present
(Prag
) loop
24338 if Pragma_Name
(Prag
) = Name_Test_Case
24340 and then String_Equal
24341 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
24343 Error_Msg_Sloc
:= Sloc
(Prag
);
24344 Error_Pragma
("name for pragma % is already used #");
24347 Prag
:= Next_Pragma
(Prag
);
24350 end Check_Distinct_Name
;
24354 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
24357 Subp_Decl
: Node_Id
;
24358 Subp_Id
: Entity_Id
;
24360 -- Start of processing for Test_Case
24364 Check_At_Least_N_Arguments
(2);
24365 Check_At_Most_N_Arguments
(4);
24367 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
24371 Check_Optional_Identifier
(Arg1
, Name_Name
);
24372 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24376 Check_Optional_Identifier
(Arg2
, Name_Mode
);
24377 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
24379 -- Arguments "Requires" and "Ensures"
24381 if Present
(Arg3
) then
24382 if Present
(Arg4
) then
24383 Check_Identifier
(Arg3
, Name_Requires
);
24384 Check_Identifier
(Arg4
, Name_Ensures
);
24386 Check_Identifier_Is_One_Of
24387 (Arg3
, Name_Requires
, Name_Ensures
);
24391 -- Pragma Test_Case must be associated with a subprogram declared
24392 -- in a library-level package. First determine whether the current
24393 -- compilation unit is a legal context.
24395 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
24396 N_Generic_Package_Declaration
)
24400 -- Otherwise the placement is illegal
24404 ("pragma % must be specified within a package declaration");
24408 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
24410 -- Find the enclosing context
24412 Context
:= Parent
(Subp_Decl
);
24414 if Present
(Context
) then
24415 Context
:= Parent
(Context
);
24418 -- Verify the placement of the pragma
24420 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
24422 ("pragma % cannot be applied to abstract subprogram");
24425 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
24426 Error_Pragma
("pragma % cannot be applied to entry");
24429 -- The context is a [generic] subprogram declared at the top level
24430 -- of the [generic] package unit.
24432 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
24433 N_Subprogram_Declaration
)
24434 and then Present
(Context
)
24435 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
24436 N_Package_Declaration
)
24440 -- Otherwise the placement is illegal
24444 ("pragma % must be applied to a library-level subprogram "
24449 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24451 -- A pragma that applies to a Ghost entity becomes Ghost for the
24452 -- purposes of legality checks and removal of ignored Ghost code.
24454 Mark_Ghost_Pragma
(N
, Subp_Id
);
24456 -- Chain the pragma on the contract for further processing by
24457 -- Analyze_Test_Case_In_Decl_Part.
24459 Add_Contract_Item
(N
, Subp_Id
);
24461 -- Preanalyze the original aspect argument "Name" for ASIS or for
24462 -- a generic subprogram to properly capture global references.
24464 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
24465 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
24467 if Present
(Asp_Arg
) then
24469 -- The argument appears with an identifier in association
24472 if Nkind
(Asp_Arg
) = N_Component_Association
then
24473 Asp_Arg
:= Expression
(Asp_Arg
);
24476 Check_Expr_Is_OK_Static_Expression
24477 (Asp_Arg
, Standard_String
);
24481 -- Ensure that the all Test_Case pragmas of the related subprogram
24482 -- have distinct names.
24484 Check_Distinct_Name
(Subp_Id
);
24486 -- Fully analyze the pragma when it appears inside an entry
24487 -- or subprogram body because it cannot benefit from forward
24490 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
24492 N_Subprogram_Body_Stub
)
24494 -- The legality checks of pragma Test_Case are affected by the
24495 -- SPARK mode in effect and the volatility of the context.
24496 -- Analyze all pragmas in a specific order.
24498 Analyze_If_Present
(Pragma_SPARK_Mode
);
24499 Analyze_If_Present
(Pragma_Volatile_Function
);
24500 Analyze_Test_Case_In_Decl_Part
(N
);
24504 --------------------------
24505 -- Thread_Local_Storage --
24506 --------------------------
24508 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24510 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
24516 Check_Arg_Count
(1);
24517 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24518 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24520 Id
:= Get_Pragma_Arg
(Arg1
);
24523 if not Is_Entity_Name
(Id
)
24524 or else Ekind
(Entity
(Id
)) /= E_Variable
24526 Error_Pragma_Arg
("local variable name required", Arg1
);
24531 -- A pragma that applies to a Ghost entity becomes Ghost for the
24532 -- purposes of legality checks and removal of ignored Ghost code.
24534 Mark_Ghost_Pragma
(N
, E
);
24536 if Rep_Item_Too_Early
(E
, N
)
24538 Rep_Item_Too_Late
(E
, N
)
24543 Set_Has_Pragma_Thread_Local_Storage
(E
);
24544 Set_Has_Gigi_Rep_Item
(E
);
24545 end Thread_Local_Storage
;
24551 -- pragma Time_Slice (static_duration_EXPRESSION);
24553 when Pragma_Time_Slice
=> Time_Slice
: declare
24559 Check_Arg_Count
(1);
24560 Check_No_Identifiers
;
24561 Check_In_Main_Program
;
24562 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
24564 if not Error_Posted
(Arg1
) then
24566 while Present
(Nod
) loop
24567 if Nkind
(Nod
) = N_Pragma
24568 and then Pragma_Name
(Nod
) = Name_Time_Slice
24570 Error_Msg_Name_1
:= Pname
;
24571 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
24578 -- Process only if in main unit
24580 if Get_Source_Unit
(Loc
) = Main_Unit
then
24581 Opt
.Time_Slice_Set
:= True;
24582 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
24584 if Val
<= Ureal_0
then
24585 Opt
.Time_Slice_Value
:= 0;
24587 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
24588 Opt
.Time_Slice_Value
:= 1_000_000_000
;
24591 Opt
.Time_Slice_Value
:=
24592 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
24601 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24603 -- TITLING_OPTION ::=
24604 -- [Title =>] STRING_LITERAL
24605 -- | [Subtitle =>] STRING_LITERAL
24607 when Pragma_Title
=> Title
: declare
24608 Args
: Args_List
(1 .. 2);
24609 Names
: constant Name_List
(1 .. 2) := (
24615 Gather_Associations
(Names
, Args
);
24618 for J
in 1 .. 2 loop
24619 if Present
(Args
(J
)) then
24620 Check_Arg_Is_OK_Static_Expression
24621 (Args
(J
), Standard_String
);
24626 ----------------------------
24627 -- Type_Invariant[_Class] --
24628 ----------------------------
24630 -- pragma Type_Invariant[_Class]
24631 -- ([Entity =>] type_LOCAL_NAME,
24632 -- [Check =>] EXPRESSION);
24634 when Pragma_Type_Invariant
24635 | Pragma_Type_Invariant_Class
24637 Type_Invariant
: declare
24638 I_Pragma
: Node_Id
;
24641 Check_Arg_Count
(2);
24643 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24644 -- setting Class_Present for the Type_Invariant_Class case.
24646 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
24647 I_Pragma
:= New_Copy
(N
);
24648 Set_Pragma_Identifier
24649 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
24650 Rewrite
(N
, I_Pragma
);
24651 Set_Analyzed
(N
, False);
24653 end Type_Invariant
;
24655 ---------------------
24656 -- Unchecked_Union --
24657 ---------------------
24659 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24661 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
24662 Assoc
: constant Node_Id
:= Arg1
;
24663 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
24673 Check_No_Identifiers
;
24674 Check_Arg_Count
(1);
24675 Check_Arg_Is_Local_Name
(Arg1
);
24677 Find_Type
(Type_Id
);
24679 Typ
:= Entity
(Type_Id
);
24681 -- A pragma that applies to a Ghost entity becomes Ghost for the
24682 -- purposes of legality checks and removal of ignored Ghost code.
24684 Mark_Ghost_Pragma
(N
, Typ
);
24687 or else Rep_Item_Too_Early
(Typ
, N
)
24691 Typ
:= Underlying_Type
(Typ
);
24694 if Rep_Item_Too_Late
(Typ
, N
) then
24698 Check_First_Subtype
(Arg1
);
24700 -- Note remaining cases are references to a type in the current
24701 -- declarative part. If we find an error, we post the error on
24702 -- the relevant type declaration at an appropriate point.
24704 if not Is_Record_Type
(Typ
) then
24705 Error_Msg_N
("unchecked union must be record type", Typ
);
24708 elsif Is_Tagged_Type
(Typ
) then
24709 Error_Msg_N
("unchecked union must not be tagged", Typ
);
24712 elsif not Has_Discriminants
(Typ
) then
24714 ("unchecked union must have one discriminant", Typ
);
24717 -- Note: in previous versions of GNAT we used to check for limited
24718 -- types and give an error, but in fact the standard does allow
24719 -- Unchecked_Union on limited types, so this check was removed.
24721 -- Similarly, GNAT used to require that all discriminants have
24722 -- default values, but this is not mandated by the RM.
24724 -- Proceed with basic error checks completed
24727 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
24728 Clist
:= Component_List
(Tdef
);
24730 -- Check presence of component list and variant part
24732 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
24734 ("unchecked union must have variant part", Tdef
);
24738 -- Check components
24740 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
24741 while Present
(Comp
) loop
24742 Check_Component
(Comp
, Typ
);
24743 Next_Non_Pragma
(Comp
);
24746 -- Check variant part
24748 Vpart
:= Variant_Part
(Clist
);
24750 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
24751 while Present
(Variant
) loop
24752 Check_Variant
(Variant
, Typ
);
24753 Next_Non_Pragma
(Variant
);
24757 Set_Is_Unchecked_Union
(Typ
);
24758 Set_Convention
(Typ
, Convention_C
);
24759 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
24760 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
24761 end Unchecked_Union
;
24763 ----------------------------
24764 -- Unevaluated_Use_Of_Old --
24765 ----------------------------
24767 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24769 when Pragma_Unevaluated_Use_Of_Old
=>
24771 Check_Arg_Count
(1);
24772 Check_No_Identifiers
;
24773 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
24775 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24776 -- a declarative part or a package spec.
24778 if not Is_Configuration_Pragma
then
24779 Check_Is_In_Decl_Part_Or_Package_Spec
;
24782 -- Store proper setting of Uneval_Old
24784 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24785 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
24787 ------------------------
24788 -- Unimplemented_Unit --
24789 ------------------------
24791 -- pragma Unimplemented_Unit;
24793 -- Note: this only gives an error if we are generating code, or if
24794 -- we are in a generic library unit (where the pragma appears in the
24795 -- body, not in the spec).
24797 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
24798 Cunitent
: constant Entity_Id
:=
24799 Cunit_Entity
(Get_Source_Unit
(Loc
));
24800 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
24804 Check_Arg_Count
(0);
24806 if Operating_Mode
= Generate_Code
24807 or else Ent_Kind
= E_Generic_Function
24808 or else Ent_Kind
= E_Generic_Procedure
24809 or else Ent_Kind
= E_Generic_Package
24811 Get_Name_String
(Chars
(Cunitent
));
24812 Set_Casing
(Mixed_Case
);
24813 Write_Str
(Name_Buffer
(1 .. Name_Len
));
24814 Write_Str
(" is not supported in this configuration");
24816 raise Unrecoverable_Error
;
24818 end Unimplemented_Unit
;
24820 ------------------------
24821 -- Universal_Aliasing --
24822 ------------------------
24824 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24826 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
24832 Check_Arg_Count
(1);
24833 Check_Optional_Identifier
(Arg2
, Name_Entity
);
24834 Check_Arg_Is_Local_Name
(Arg1
);
24835 E_Id
:= Get_Pragma_Arg
(Arg1
);
24837 if Etype
(E_Id
) = Any_Type
then
24841 E
:= Entity
(E_Id
);
24843 if not Is_Type
(E
) then
24844 Error_Pragma_Arg
("pragma% requires type", Arg1
);
24847 -- A pragma that applies to a Ghost entity becomes Ghost for the
24848 -- purposes of legality checks and removal of ignored Ghost code.
24850 Mark_Ghost_Pragma
(N
, E
);
24851 Set_Universal_Aliasing
(Base_Type
(E
));
24852 Record_Rep_Item
(E
, N
);
24853 end Universal_Alias
;
24855 --------------------
24856 -- Universal_Data --
24857 --------------------
24859 -- pragma Universal_Data [(library_unit_NAME)];
24861 when Pragma_Universal_Data
=>
24863 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
24869 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24871 when Pragma_Unmodified
=>
24872 Analyze_Unmodified_Or_Unused
;
24878 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24880 -- or when used in a context clause:
24882 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24884 when Pragma_Unreferenced
=>
24885 Analyze_Unreferenced_Or_Unused
;
24887 --------------------------
24888 -- Unreferenced_Objects --
24889 --------------------------
24891 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24893 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
24895 Arg_Expr
: Node_Id
;
24896 Arg_Id
: Entity_Id
;
24898 Ghost_Error_Posted
: Boolean := False;
24899 -- Flag set when an error concerning the illegal mix of Ghost and
24900 -- non-Ghost types is emitted.
24902 Ghost_Id
: Entity_Id
:= Empty
;
24903 -- The entity of the first Ghost type encountered while processing
24904 -- the arguments of the pragma.
24908 Check_At_Least_N_Arguments
(1);
24911 while Present
(Arg
) loop
24912 Check_No_Identifier
(Arg
);
24913 Check_Arg_Is_Local_Name
(Arg
);
24914 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
24916 if Is_Entity_Name
(Arg_Expr
) then
24917 Arg_Id
:= Entity
(Arg_Expr
);
24919 if Is_Type
(Arg_Id
) then
24920 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
24922 -- A pragma that applies to a Ghost entity becomes Ghost
24923 -- for the purposes of legality checks and removal of
24924 -- ignored Ghost code.
24926 Mark_Ghost_Pragma
(N
, Arg_Id
);
24928 -- Capture the entity of the first Ghost type being
24929 -- processed for error detection purposes.
24931 if Is_Ghost_Entity
(Arg_Id
) then
24932 if No
(Ghost_Id
) then
24933 Ghost_Id
:= Arg_Id
;
24936 -- Otherwise the type is non-Ghost. It is illegal to mix
24937 -- references to Ghost and non-Ghost entities
24940 elsif Present
(Ghost_Id
)
24941 and then not Ghost_Error_Posted
24943 Ghost_Error_Posted
:= True;
24945 Error_Msg_Name_1
:= Pname
;
24947 ("pragma % cannot mention ghost and non-ghost types",
24950 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
24951 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
24953 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
24954 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
24958 ("argument for pragma% must be type or subtype", Arg
);
24962 ("argument for pragma% must be type or subtype", Arg
);
24967 end Unreferenced_Objects
;
24969 ------------------------------
24970 -- Unreserve_All_Interrupts --
24971 ------------------------------
24973 -- pragma Unreserve_All_Interrupts;
24975 when Pragma_Unreserve_All_Interrupts
=>
24977 Check_Arg_Count
(0);
24979 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
24980 Unreserve_All_Interrupts
:= True;
24987 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24989 when Pragma_Unsuppress
=>
24991 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
24997 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24999 when Pragma_Unused
=>
25000 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
25001 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
25003 -------------------
25004 -- Use_VADS_Size --
25005 -------------------
25007 -- pragma Use_VADS_Size;
25009 when Pragma_Use_VADS_Size
=>
25011 Check_Arg_Count
(0);
25012 Check_Valid_Configuration_Pragma
;
25013 Use_VADS_Size
:= True;
25015 ---------------------
25016 -- Validity_Checks --
25017 ---------------------
25019 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25021 when Pragma_Validity_Checks
=> Validity_Checks
: declare
25022 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25028 Check_Arg_Count
(1);
25029 Check_No_Identifiers
;
25031 -- Pragma always active unless in CodePeer or GNATprove modes,
25032 -- which use a fixed configuration of validity checks.
25034 if not (CodePeer_Mode
or GNATprove_Mode
) then
25035 if Nkind
(A
) = N_String_Literal
then
25039 Slen
: constant Natural := Natural (String_Length
(S
));
25040 Options
: String (1 .. Slen
);
25044 -- Couldn't we use a for loop here over Options'Range???
25048 C
:= Get_String_Char
(S
, Pos
(J
));
25050 -- This is a weird test, it skips setting validity
25051 -- checks entirely if any element of S is out of
25052 -- range of Character, what is that about ???
25054 exit when not In_Character_Range
(C
);
25055 Options
(J
) := Get_Character
(C
);
25058 Set_Validity_Check_Options
(Options
);
25066 elsif Nkind
(A
) = N_Identifier
then
25067 if Chars
(A
) = Name_All_Checks
then
25068 Set_Validity_Check_Options
("a");
25069 elsif Chars
(A
) = Name_On
then
25070 Validity_Checks_On
:= True;
25071 elsif Chars
(A
) = Name_Off
then
25072 Validity_Checks_On
:= False;
25076 end Validity_Checks
;
25082 -- pragma Volatile (LOCAL_NAME);
25084 when Pragma_Volatile
=>
25085 Process_Atomic_Independent_Shared_Volatile
;
25087 -------------------------
25088 -- Volatile_Components --
25089 -------------------------
25091 -- pragma Volatile_Components (array_LOCAL_NAME);
25093 -- Volatile is handled by the same circuit as Atomic_Components
25095 --------------------------
25096 -- Volatile_Full_Access --
25097 --------------------------
25099 -- pragma Volatile_Full_Access (LOCAL_NAME);
25101 when Pragma_Volatile_Full_Access
=>
25103 Process_Atomic_Independent_Shared_Volatile
;
25105 -----------------------
25106 -- Volatile_Function --
25107 -----------------------
25109 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25111 when Pragma_Volatile_Function
=> Volatile_Function
: declare
25112 Over_Id
: Entity_Id
;
25113 Spec_Id
: Entity_Id
;
25114 Subp_Decl
: Node_Id
;
25118 Check_No_Identifiers
;
25119 Check_At_Most_N_Arguments
(1);
25122 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25124 -- Generic subprogram
25126 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25129 -- Body acts as spec
25131 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25132 and then No
(Corresponding_Spec
(Subp_Decl
))
25136 -- Body stub acts as spec
25138 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25139 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25145 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25153 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25155 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
25160 -- A pragma that applies to a Ghost entity becomes Ghost for the
25161 -- purposes of legality checks and removal of ignored Ghost code.
25163 Mark_Ghost_Pragma
(N
, Spec_Id
);
25165 -- Chain the pragma on the contract for completeness
25167 Add_Contract_Item
(N
, Spec_Id
);
25169 -- The legality checks of pragma Volatile_Function are affected by
25170 -- the SPARK mode in effect. Analyze all pragmas in a specific
25173 Analyze_If_Present
(Pragma_SPARK_Mode
);
25175 -- A volatile function cannot override a non-volatile function
25176 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25177 -- in New_Overloaded_Entity, however at that point the pragma has
25178 -- not been processed yet.
25180 Over_Id
:= Overridden_Operation
(Spec_Id
);
25182 if Present
(Over_Id
)
25183 and then not Is_Volatile_Function
(Over_Id
)
25186 ("incompatible volatile function values in effect", Spec_Id
);
25188 Error_Msg_Sloc
:= Sloc
(Over_Id
);
25190 ("\& declared # with Volatile_Function value False",
25193 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
25195 ("\overridden # with Volatile_Function value True",
25199 -- Analyze the Boolean expression (if any)
25201 if Present
(Arg1
) then
25202 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
25204 end Volatile_Function
;
25206 ----------------------
25207 -- Warning_As_Error --
25208 ----------------------
25210 -- pragma Warning_As_Error (static_string_EXPRESSION);
25212 when Pragma_Warning_As_Error
=>
25214 Check_Arg_Count
(1);
25215 Check_No_Identifiers
;
25216 Check_Valid_Configuration_Pragma
;
25218 if not Is_Static_String_Expression
(Arg1
) then
25220 ("argument of pragma% must be static string expression",
25223 -- OK static string expression
25226 Acquire_Warning_Match_String
(Arg1
);
25227 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
25228 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
25229 new String'(Name_Buffer (1 .. Name_Len));
25236 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25238 -- DETAILS ::= On | Off
25239 -- DETAILS ::= On | Off, local_NAME
25240 -- DETAILS ::= static_string_EXPRESSION
25241 -- DETAILS ::= On | Off, static_string_EXPRESSION
25243 -- TOOL_NAME ::= GNAT | GNATProve
25245 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25247 -- Note: If the first argument matches an allowed tool name, it is
25248 -- always considered to be a tool name, even if there is a string
25249 -- variable of that name.
25251 -- Note if the second argument of DETAILS is a local_NAME then the
25252 -- second form is always understood. If the intention is to use
25253 -- the fourth form, then you can write NAME & "" to force the
25254 -- intepretation as a static_string_EXPRESSION.
25256 when Pragma_Warnings => Warnings : declare
25257 Reason : String_Id;
25261 Check_At_Least_N_Arguments (1);
25263 -- See if last argument is labeled Reason. If so, make sure we
25264 -- have a string literal or a concatenation of string literals,
25265 -- and acquire the REASON string. Then remove the REASON argument
25266 -- by decreasing Num_Args by one; Remaining processing looks only
25267 -- at first Num_Args arguments).
25270 Last_Arg : constant Node_Id :=
25271 Last (Pragma_Argument_Associations (N));
25274 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25275 and then Chars (Last_Arg) = Name_Reason
25278 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25279 Reason := End_String;
25280 Arg_Count := Arg_Count - 1;
25282 -- Not allowed in compiler units (bootstrap issues)
25284 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25286 -- No REASON string, set null string as reason
25289 Reason := Null_String_Id;
25293 -- Now proceed with REASON taken care of and eliminated
25295 Check_No_Identifiers;
25297 -- If debug flag -gnatd.i is set, pragma is ignored
25299 if Debug_Flag_Dot_I then
25303 -- Process various forms of the pragma
25306 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25307 Shifted_Args : List_Id;
25310 -- See if first argument is a tool name, currently either
25311 -- GNAT or GNATprove. If so, either ignore the pragma if the
25312 -- tool used does not match, or continue as if no tool name
25313 -- was given otherwise, by shifting the arguments.
25315 if Nkind (Argx) = N_Identifier
25316 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25318 if Chars (Argx) = Name_Gnat then
25319 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25320 Rewrite (N, Make_Null_Statement (Loc));
25325 elsif Chars (Argx) = Name_Gnatprove then
25326 if not GNATprove_Mode then
25327 Rewrite (N, Make_Null_Statement (Loc));
25333 raise Program_Error;
25336 -- At this point, the pragma Warnings applies to the tool,
25337 -- so continue with shifted arguments.
25339 Arg_Count := Arg_Count - 1;
25341 if Arg_Count = 1 then
25342 Shifted_Args := New_List (New_Copy (Arg2));
25343 elsif Arg_Count = 2 then
25344 Shifted_Args := New_List (New_Copy (Arg2),
25346 elsif Arg_Count = 3 then
25347 Shifted_Args := New_List (New_Copy (Arg2),
25351 raise Program_Error;
25356 Chars => Name_Warnings,
25357 Pragma_Argument_Associations => Shifted_Args));
25362 -- One argument case
25364 if Arg_Count = 1 then
25366 -- On/Off one argument case was processed by parser
25368 if Nkind (Argx) = N_Identifier
25369 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25373 -- One argument case must be ON/OFF or static string expr
25375 elsif not Is_Static_String_Expression (Arg1) then
25377 ("argument of pragma% must be On/Off or static string "
25378 & "expression", Arg1);
25380 -- One argument string expression case
25384 Lit : constant Node_Id := Expr_Value_S (Argx);
25385 Str : constant String_Id := Strval (Lit);
25386 Len : constant Nat := String_Length (Str);
25394 while J <= Len loop
25395 C := Get_String_Char (Str, J);
25396 OK := In_Character_Range (C);
25399 Chr := Get_Character (C);
25401 -- Dash case: only -Wxxx is accepted
25408 C := Get_String_Char (Str, J);
25409 Chr := Get_Character (C);
25410 exit when Chr = 'W
';
25415 elsif J < Len and then Chr = '.' then
25417 C := Get_String_Char (Str, J);
25418 Chr := Get_Character (C);
25420 if not Set_Dot_Warning_Switch (Chr) then
25422 ("invalid warning switch character "
25423 & '.' & Chr, Arg1);
25429 OK := Set_Warning_Switch (Chr);
25434 ("invalid warning switch character " & Chr,
25440 ("invalid wide character in warning switch ",
25449 -- Two or more arguments (must be two)
25452 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25453 Check_Arg_Count (2);
25461 E_Id := Get_Pragma_Arg (Arg2);
25464 -- In the expansion of an inlined body, a reference to
25465 -- the formal may be wrapped in a conversion if the
25466 -- actual is a conversion. Retrieve the real entity name.
25468 if (In_Instance_Body or In_Inlined_Body)
25469 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25471 E_Id := Expression (E_Id);
25474 -- Entity name case
25476 if Is_Entity_Name (E_Id) then
25477 E := Entity (E_Id);
25484 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25487 -- Suppress elaboration warnings if the entity
25488 -- denotes an elaboration target.
25490 if Is_Elaboration_Target (E) then
25491 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25494 -- For OFF case, make entry in warnings off
25495 -- pragma table for later processing. But we do
25496 -- not do that within an instance, since these
25497 -- warnings are about what is needed in the
25498 -- template, not an instance of it.
25500 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25501 and then Warn_On_Warnings_Off
25502 and then not In_Instance
25504 Warnings_Off_Pragmas.Append ((N, E, Reason));
25507 if Is_Enumeration_Type (E) then
25511 Lit := First_Literal (E);
25512 while Present (Lit) loop
25513 Set_Warnings_Off (Lit);
25514 Next_Literal (Lit);
25519 exit when No (Homonym (E));
25524 -- Error if not entity or static string expression case
25526 elsif not Is_Static_String_Expression (Arg2) then
25528 ("second argument of pragma% must be entity name "
25529 & "or static string expression", Arg2);
25531 -- Static string expression case
25534 Acquire_Warning_Match_String (Arg2);
25536 -- Note on configuration pragma case: If this is a
25537 -- configuration pragma, then for an OFF pragma, we
25538 -- just set Config True in the call, which is all
25539 -- that needs to be done. For the case of ON, this
25540 -- is normally an error, unless it is canceling the
25541 -- effect of a previous OFF pragma in the same file.
25542 -- In any other case, an error will be signalled (ON
25543 -- with no matching OFF).
25545 -- Note: We set Used if we are inside a generic to
25546 -- disable the test that the non-config case actually
25547 -- cancels a warning. That's because we can't be sure
25548 -- there isn't an instantiation in some other unit
25549 -- where a warning is suppressed.
25551 -- We could do a little better here by checking if the
25552 -- generic unit we are inside is public, but for now
25553 -- we don't bother with that refinement.
25555 if Chars (Argx) = Name_Off then
25556 Set_Specific_Warning_Off
25557 (Loc, Name_Buffer (1 .. Name_Len), Reason,
25558 Config => Is_Configuration_Pragma,
25559 Used => Inside_A_Generic or else In_Instance);
25561 elsif Chars (Argx) = Name_On then
25562 Set_Specific_Warning_On
25563 (Loc, Name_Buffer (1 .. Name_Len), Err);
25567 ("??pragma Warnings On with no matching "
25568 & "Warnings Off", Loc);
25577 -------------------
25578 -- Weak_External --
25579 -------------------
25581 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25583 when Pragma_Weak_External => Weak_External : declare
25588 Check_Arg_Count (1);
25589 Check_Optional_Identifier (Arg1, Name_Entity);
25590 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25591 Ent := Entity (Get_Pragma_Arg (Arg1));
25593 if Rep_Item_Too_Early (Ent, N) then
25596 Ent := Underlying_Type (Ent);
25599 -- The only processing required is to link this item on to the
25600 -- list of rep items for the given entity. This is accomplished
25601 -- by the call to Rep_Item_Too_Late (when no error is detected
25602 -- and False is returned).
25604 if Rep_Item_Too_Late (Ent, N) then
25607 Set_Has_Gigi_Rep_Item (Ent);
25611 -----------------------------
25612 -- Wide_Character_Encoding --
25613 -----------------------------
25615 -- pragma Wide_Character_Encoding (IDENTIFIER);
25617 when Pragma_Wide_Character_Encoding =>
25620 -- Nothing to do, handled in parser. Note that we do not enforce
25621 -- configuration pragma placement, this pragma can appear at any
25622 -- place in the source, allowing mixed encodings within a single
25627 --------------------
25628 -- Unknown_Pragma --
25629 --------------------
25631 -- Should be impossible, since the case of an unknown pragma is
25632 -- separately processed before the case statement is entered.
25634 when Unknown_Pragma =>
25635 raise Program_Error;
25638 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25639 -- until AI is formally approved.
25641 -- Check_Order_Dependence;
25644 when Pragma_Exit => null;
25645 end Analyze_Pragma;
25647 ---------------------------------------------
25648 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25649 ---------------------------------------------
25651 -- WARNING: This routine manages Ghost regions. Return statements must be
25652 -- replaced by gotos which jump to the end of the routine and restore the
25655 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25657 Freeze_Id : Entity_Id := Empty)
25659 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25660 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25662 Disp_Typ : Entity_Id;
25663 -- The dispatching type of the subprogram subject to the pre- or
25666 function Check_References (Nod : Node_Id) return Traverse_Result;
25667 -- Check that expression Nod does not mention non-primitives of the
25668 -- type, global objects of the type, or other illegalities described
25669 -- and implied by AI12-0113.
25671 ----------------------
25672 -- Check_References --
25673 ----------------------
25675 function Check_References (Nod : Node_Id) return Traverse_Result is
25677 if Nkind (Nod) = N_Function_Call
25678 and then Is_Entity_Name (Name (Nod))
25681 Func : constant Entity_Id := Entity (Name (Nod));
25685 -- An operation of the type must be a primitive
25687 if No (Find_Dispatching_Type (Func)) then
25688 Form := First_Formal (Func);
25689 while Present (Form) loop
25690 if Etype (Form) = Disp_Typ then
25692 ("operation in class-wide condition must be "
25693 & "primitive of &", Nod, Disp_Typ);
25696 Next_Formal (Form);
25699 -- A return object of the type is illegal as well
25701 if Etype (Func) = Disp_Typ
25702 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25705 ("operation in class-wide condition must be primitive "
25706 & "of &", Nod, Disp_Typ);
25709 -- Otherwise we have a call to an overridden primitive, and we
25710 -- will create a common class-wide clone for the body of
25711 -- original operation and its eventual inherited versions. If
25712 -- the original operation dispatches on result it is never
25713 -- inherited and there is no need for a clone. There is not
25714 -- need for a clone either in GNATprove mode, as cases that
25715 -- would require it are rejected (when an inherited primitive
25716 -- calls an overridden operation in a class-wide contract), and
25717 -- the clone would make proof impossible in some cases.
25719 elsif not Is_Abstract_Subprogram (Spec_Id)
25720 and then No (Class_Wide_Clone (Spec_Id))
25721 and then not Has_Controlling_Result (Spec_Id)
25722 and then not GNATprove_Mode
25724 Build_Class_Wide_Clone_Decl (Spec_Id);
25728 elsif Is_Entity_Name (Nod)
25730 (Etype (Nod) = Disp_Typ
25731 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25732 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25735 ("object in class-wide condition must be formal of type &",
25738 elsif Nkind (Nod) = N_Explicit_Dereference
25739 and then (Etype (Nod) = Disp_Typ
25740 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25741 and then (not Is_Entity_Name (Prefix (Nod))
25742 or else not Is_Formal (Entity (Prefix (Nod))))
25745 ("operation in class-wide condition must be primitive of &",
25750 end Check_References;
25752 procedure Check_Class_Wide_Condition is
25753 new Traverse_Proc (Check_References);
25757 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25759 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25760 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25761 -- Save the Ghost-related attributes to restore on exit
25764 Restore_Scope : Boolean := False;
25766 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25769 -- Do not analyze the pragma multiple times
25771 if Is_Analyzed_Pragma (N) then
25775 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25776 -- analysis of the pragma, the Ghost mode at point of declaration and
25777 -- point of analysis may not necessarily be the same. Use the mode in
25778 -- effect at the point of declaration.
25780 Set_Ghost_Mode (N);
25782 -- Ensure that the subprogram and its formals are visible when analyzing
25783 -- the expression of the pragma.
25785 if not In_Open_Scopes (Spec_Id) then
25786 Restore_Scope := True;
25787 Push_Scope (Spec_Id);
25789 if Is_Generic_Subprogram (Spec_Id) then
25790 Install_Generic_Formals (Spec_Id);
25792 Install_Formals (Spec_Id);
25796 Errors := Serious_Errors_Detected;
25797 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25799 -- Emit a clarification message when the expression contains at least
25800 -- one undefined reference, possibly due to contract freezing.
25802 if Errors /= Serious_Errors_Detected
25803 and then Present (Freeze_Id)
25804 and then Has_Undefined_Reference (Expr)
25806 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25809 if Class_Present (N) then
25811 -- Verify that a class-wide condition is legal, i.e. the operation is
25812 -- a primitive of a tagged type. Note that a generic subprogram is
25813 -- not a primitive operation.
25815 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25817 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25818 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25820 if From_Aspect_Specification (N) then
25822 ("aspect % can only be specified for a primitive operation "
25823 & "of a tagged type", Corresponding_Aspect (N));
25825 -- The pragma is a source construct
25829 ("pragma % can only be specified for a primitive operation "
25830 & "of a tagged type", N);
25833 -- Remaining semantic checks require a full tree traversal
25836 Check_Class_Wide_Condition (Expr);
25841 if Restore_Scope then
25845 -- If analysis of the condition indicates that a class-wide clone
25846 -- has been created, build and analyze its declaration.
25848 if Is_Subprogram (Spec_Id)
25849 and then Present (Class_Wide_Clone (Spec_Id))
25851 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25854 -- Currently it is not possible to inline pre/postconditions on a
25855 -- subprogram subject to pragma Inline_Always.
25857 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25858 Set_Is_Analyzed_Pragma (N);
25860 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25861 end Analyze_Pre_Post_Condition_In_Decl_Part;
25863 ------------------------------------------
25864 -- Analyze_Refined_Depends_In_Decl_Part --
25865 ------------------------------------------
25867 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25868 procedure Check_Dependency_Clause
25869 (Spec_Id : Entity_Id;
25870 Dep_Clause : Node_Id;
25871 Dep_States : Elist_Id;
25872 Refinements : List_Id;
25873 Matched_Items : in out Elist_Id);
25874 -- Try to match a single dependency clause Dep_Clause against one or
25875 -- more refinement clauses found in list Refinements. Each successful
25876 -- match eliminates at least one refinement clause from Refinements.
25877 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25878 -- denotes the entities of all abstract states which appear in pragma
25879 -- Depends. Matched_Items contains the entities of all successfully
25880 -- matched items found in pragma Depends.
25882 procedure Check_Output_States
25883 (Spec_Id : Entity_Id;
25884 Spec_Inputs : Elist_Id;
25885 Spec_Outputs : Elist_Id;
25886 Body_Inputs : Elist_Id;
25887 Body_Outputs : Elist_Id);
25888 -- Determine whether pragma Depends contains an output state with a
25889 -- visible refinement and if so, ensure that pragma Refined_Depends
25890 -- mentions all its constituents as outputs. Spec_Id is the entity of
25891 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25892 -- inputs and outputs of the subprogram spec synthesized from pragma
25893 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25894 -- of the subprogram body synthesized from pragma Refined_Depends.
25896 function Collect_States (Clauses : List_Id) return Elist_Id;
25897 -- Given a normalized list of dependencies obtained from calling
25898 -- Normalize_Clauses, return a list containing the entities of all
25899 -- states appearing in dependencies. It helps in checking refinements
25900 -- involving a state and a corresponding constituent which is not a
25901 -- direct constituent of the state.
25903 procedure Normalize_Clauses (Clauses : List_Id);
25904 -- Given a list of dependence or refinement clauses Clauses, normalize
25905 -- each clause by creating multiple dependencies with exactly one input
25908 procedure Remove_Extra_Clauses
25909 (Clauses : List_Id;
25910 Matched_Items : Elist_Id);
25911 -- Given a list of refinement clauses Clauses, remove all clauses whose
25912 -- inputs and/or outputs have been previously matched. See the body for
25913 -- all special cases. Matched_Items contains the entities of all matched
25914 -- items found in pragma Depends.
25916 procedure Report_Extra_Clauses
25917 (Spec_Id : Entity_Id;
25918 Clauses : List_Id);
25919 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25920 -- denotes the entity of the related subprogram.
25922 -----------------------------
25923 -- Check_Dependency_Clause --
25924 -----------------------------
25926 procedure Check_Dependency_Clause
25927 (Spec_Id : Entity_Id;
25928 Dep_Clause : Node_Id;
25929 Dep_States : Elist_Id;
25930 Refinements : List_Id;
25931 Matched_Items : in out Elist_Id)
25933 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25934 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25936 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25937 -- Determine whether dependency item Dep_Item has been matched in a
25938 -- previous clause.
25940 function Is_In_Out_State_Clause return Boolean;
25941 -- Determine whether dependence clause Dep_Clause denotes an abstract
25942 -- state that depends on itself (State => State).
25944 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25945 -- Determine whether item Item denotes an abstract state with visible
25946 -- null refinement.
25948 procedure Match_Items
25949 (Dep_Item : Node_Id;
25950 Ref_Item : Node_Id;
25951 Matched : out Boolean);
25952 -- Try to match dependence item Dep_Item against refinement item
25953 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25954 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25955 -- the following conformance scenarios is in effect:
25956 -- 1) Both items denote null
25957 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25958 -- 3) Both items denote attribute 'Result
25959 -- 4) Both items denote the same object
25960 -- 5) Both items denote the same formal parameter
25961 -- 6) Both items denote the same current instance of a type
25962 -- 7) Both items denote the same discriminant
25963 -- 8) Dep_Item is an abstract state with visible null refinement
25964 -- and Ref_Item denotes null.
25965 -- 9) Dep_Item is an abstract state with visible null refinement
25966 -- and Ref_Item is Empty (special case).
25967 -- 10) Dep_Item is an abstract state with full or partial visible
25968 -- non-null refinement and Ref_Item denotes one of its
25970 -- 11) Dep_Item is an abstract state without a full visible
25971 -- refinement and Ref_Item denotes the same state.
25972 -- When scenario 10 is in effect, the entity of the abstract state
25973 -- denoted by Dep_Item is added to list Refined_States.
25975 procedure Record_Item
(Item_Id
: Entity_Id
);
25976 -- Store the entity of an item denoted by Item_Id in Matched_Items
25978 ------------------------
25979 -- Is_Already_Matched --
25980 ------------------------
25982 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
25983 Item_Id
: Entity_Id
:= Empty
;
25986 -- When the dependency item denotes attribute 'Result, check for
25987 -- the entity of the related subprogram.
25989 if Is_Attribute_Result
(Dep_Item
) then
25990 Item_Id
:= Spec_Id
;
25992 elsif Is_Entity_Name
(Dep_Item
) then
25993 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25997 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
25998 end Is_Already_Matched
;
26000 ----------------------------
26001 -- Is_In_Out_State_Clause --
26002 ----------------------------
26004 function Is_In_Out_State_Clause
return Boolean is
26005 Dep_Input_Id
: Entity_Id
;
26006 Dep_Output_Id
: Entity_Id
;
26009 -- Detect the following clause:
26012 if Is_Entity_Name
(Dep_Input
)
26013 and then Is_Entity_Name
(Dep_Output
)
26015 -- Handle abstract views generated for limited with clauses
26017 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
26018 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
26021 Ekind
(Dep_Input_Id
) = E_Abstract_State
26022 and then Dep_Input_Id
= Dep_Output_Id
;
26026 end Is_In_Out_State_Clause
;
26028 ---------------------------
26029 -- Is_Null_Refined_State --
26030 ---------------------------
26032 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
26033 Item_Id
: Entity_Id
;
26036 if Is_Entity_Name
(Item
) then
26038 -- Handle abstract views generated for limited with clauses
26040 Item_Id
:= Available_View
(Entity_Of
(Item
));
26043 Ekind
(Item_Id
) = E_Abstract_State
26044 and then Has_Null_Visible_Refinement
(Item_Id
);
26048 end Is_Null_Refined_State
;
26054 procedure Match_Items
26055 (Dep_Item
: Node_Id
;
26056 Ref_Item
: Node_Id
;
26057 Matched
: out Boolean)
26059 Dep_Item_Id
: Entity_Id
;
26060 Ref_Item_Id
: Entity_Id
;
26063 -- Assume that the two items do not match
26067 -- A null matches null or Empty (special case)
26069 if Nkind
(Dep_Item
) = N_Null
26070 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26074 -- Attribute 'Result matches attribute 'Result
26076 elsif Is_Attribute_Result
(Dep_Item
)
26077 and then Is_Attribute_Result
(Ref_Item
)
26079 -- Put the entity of the related function on the list of
26080 -- matched items because attribute 'Result does not carry
26081 -- an entity similar to states and constituents.
26083 Record_Item
(Spec_Id
);
26086 -- Abstract states, current instances of concurrent types,
26087 -- discriminants, formal parameters and objects.
26089 elsif Is_Entity_Name
(Dep_Item
) then
26091 -- Handle abstract views generated for limited with clauses
26093 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26095 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
26097 -- An abstract state with visible null refinement matches
26098 -- null or Empty (special case).
26100 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
26101 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26103 Record_Item
(Dep_Item_Id
);
26106 -- An abstract state with visible non-null refinement
26107 -- matches one of its constituents, or itself for an
26108 -- abstract state with partial visible refinement.
26110 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
26111 if Is_Entity_Name
(Ref_Item
) then
26112 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
26114 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
26117 and then Present
(Encapsulating_State
(Ref_Item_Id
))
26118 and then Find_Encapsulating_State
26119 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
26121 Record_Item
(Dep_Item_Id
);
26124 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
26125 and then Ref_Item_Id
= Dep_Item_Id
26127 Record_Item
(Dep_Item_Id
);
26132 -- An abstract state without a visible refinement matches
26135 elsif Is_Entity_Name
(Ref_Item
)
26136 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26138 Record_Item
(Dep_Item_Id
);
26142 -- A current instance of a concurrent type, discriminant,
26143 -- formal parameter or an object matches itself.
26145 elsif Is_Entity_Name
(Ref_Item
)
26146 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26148 Record_Item
(Dep_Item_Id
);
26158 procedure Record_Item
(Item_Id
: Entity_Id
) is
26160 if No
(Matched_Items
) then
26161 Matched_Items
:= New_Elmt_List
;
26164 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
26169 Clause_Matched
: Boolean := False;
26170 Dummy
: Boolean := False;
26171 Inputs_Match
: Boolean;
26172 Next_Ref_Clause
: Node_Id
;
26173 Outputs_Match
: Boolean;
26174 Ref_Clause
: Node_Id
;
26175 Ref_Input
: Node_Id
;
26176 Ref_Output
: Node_Id
;
26178 -- Start of processing for Check_Dependency_Clause
26181 -- Do not perform this check in an instance because it was already
26182 -- performed successfully in the generic template.
26184 if Is_Generic_Instance
(Spec_Id
) then
26188 -- Examine all refinement clauses and compare them against the
26189 -- dependence clause.
26191 Ref_Clause
:= First
(Refinements
);
26192 while Present
(Ref_Clause
) loop
26193 Next_Ref_Clause
:= Next
(Ref_Clause
);
26195 -- Obtain the attributes of the current refinement clause
26197 Ref_Input
:= Expression
(Ref_Clause
);
26198 Ref_Output
:= First
(Choices
(Ref_Clause
));
26200 -- The current refinement clause matches the dependence clause
26201 -- when both outputs match and both inputs match. See routine
26202 -- Match_Items for all possible conformance scenarios.
26204 -- Depends Dep_Output => Dep_Input
26208 -- Refined_Depends Ref_Output => Ref_Input
26211 (Dep_Item
=> Dep_Input
,
26212 Ref_Item
=> Ref_Input
,
26213 Matched
=> Inputs_Match
);
26216 (Dep_Item
=> Dep_Output
,
26217 Ref_Item
=> Ref_Output
,
26218 Matched
=> Outputs_Match
);
26220 -- An In_Out state clause may be matched against a refinement with
26221 -- a null input or null output as long as the non-null side of the
26222 -- relation contains a valid constituent of the In_Out_State.
26224 if Is_In_Out_State_Clause
then
26226 -- Depends => (State => State)
26227 -- Refined_Depends => (null => Constit) -- OK
26230 and then not Outputs_Match
26231 and then Nkind
(Ref_Output
) = N_Null
26233 Outputs_Match
:= True;
26236 -- Depends => (State => State)
26237 -- Refined_Depends => (Constit => null) -- OK
26239 if not Inputs_Match
26240 and then Outputs_Match
26241 and then Nkind
(Ref_Input
) = N_Null
26243 Inputs_Match
:= True;
26247 -- The current refinement clause is legally constructed following
26248 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26249 -- the pool of candidates. The seach continues because a single
26250 -- dependence clause may have multiple matching refinements.
26252 if Inputs_Match
and Outputs_Match
then
26253 Clause_Matched
:= True;
26254 Remove
(Ref_Clause
);
26257 Ref_Clause
:= Next_Ref_Clause
;
26260 -- Depending on the order or composition of refinement clauses, an
26261 -- In_Out state clause may not be directly refinable.
26263 -- Refined_State => (State => (Constit_1, Constit_2))
26264 -- Depends => ((Output, State) => (Input, State))
26265 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26267 -- Matching normalized clause (State => State) fails because there is
26268 -- no direct refinement capable of satisfying this relation. Another
26269 -- similar case arises when clauses (Constit_1 => Input) and (Output
26270 -- => Constit_2) are matched first, leaving no candidates for clause
26271 -- (State => State). Both scenarios are legal as long as one of the
26272 -- previous clauses mentioned a valid constituent of State.
26274 if not Clause_Matched
26275 and then Is_In_Out_State_Clause
26276 and then Is_Already_Matched
(Dep_Input
)
26278 Clause_Matched
:= True;
26281 -- A clause where the input is an abstract state with visible null
26282 -- refinement or a 'Result attribute is implicitly matched when the
26283 -- output has already been matched in a previous clause.
26285 -- Refined_State => (State => null)
26286 -- Depends => (Output => State) -- implicitly OK
26287 -- Refined_Depends => (Output => ...)
26288 -- Depends => (...'Result => State) -- implicitly OK
26289 -- Refined_Depends => (...'Result => ...)
26291 if not Clause_Matched
26292 and then Is_Null_Refined_State
(Dep_Input
)
26293 and then Is_Already_Matched
(Dep_Output
)
26295 Clause_Matched
:= True;
26298 -- A clause where the output is an abstract state with visible null
26299 -- refinement is implicitly matched when the input has already been
26300 -- matched in a previous clause.
26302 -- Refined_State => (State => null)
26303 -- Depends => (State => Input) -- implicitly OK
26304 -- Refined_Depends => (... => Input)
26306 if not Clause_Matched
26307 and then Is_Null_Refined_State
(Dep_Output
)
26308 and then Is_Already_Matched
(Dep_Input
)
26310 Clause_Matched
:= True;
26313 -- At this point either all refinement clauses have been examined or
26314 -- pragma Refined_Depends contains a solitary null. Only an abstract
26315 -- state with null refinement can possibly match these cases.
26317 -- Refined_State => (State => null)
26318 -- Depends => (State => null)
26319 -- Refined_Depends => null -- OK
26321 if not Clause_Matched
then
26323 (Dep_Item
=> Dep_Input
,
26325 Matched
=> Inputs_Match
);
26328 (Dep_Item
=> Dep_Output
,
26330 Matched
=> Outputs_Match
);
26332 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
26335 -- If the contents of Refined_Depends are legal, then the current
26336 -- dependence clause should be satisfied either by an explicit match
26337 -- or by one of the special cases.
26339 if not Clause_Matched
then
26341 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
26342 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
26344 end Check_Dependency_Clause
;
26346 -------------------------
26347 -- Check_Output_States --
26348 -------------------------
26350 procedure Check_Output_States
26351 (Spec_Id
: Entity_Id
;
26352 Spec_Inputs
: Elist_Id
;
26353 Spec_Outputs
: Elist_Id
;
26354 Body_Inputs
: Elist_Id
;
26355 Body_Outputs
: Elist_Id
)
26357 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26358 -- Determine whether all constituents of state State_Id with full
26359 -- visible refinement are used as outputs in pragma Refined_Depends.
26360 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26362 -----------------------------
26363 -- Check_Constituent_Usage --
26364 -----------------------------
26366 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26367 Constits
: constant Elist_Id
:=
26368 Partial_Refinement_Constituents
(State_Id
);
26369 Constit_Elmt
: Elmt_Id
;
26370 Constit_Id
: Entity_Id
;
26371 Only_Partial
: constant Boolean :=
26372 not Has_Visible_Refinement
(State_Id
);
26373 Posted
: Boolean := False;
26376 if Present
(Constits
) then
26377 Constit_Elmt
:= First_Elmt
(Constits
);
26378 while Present
(Constit_Elmt
) loop
26379 Constit_Id
:= Node
(Constit_Elmt
);
26381 -- Issue an error when a constituent of State_Id is used,
26382 -- and State_Id has only partial visible refinement
26383 -- (SPARK RM 7.2.4(3d)).
26385 if Only_Partial
then
26386 if (Present
(Body_Inputs
)
26387 and then Appears_In
(Body_Inputs
, Constit_Id
))
26389 (Present
(Body_Outputs
)
26390 and then Appears_In
(Body_Outputs
, Constit_Id
))
26392 Error_Msg_Name_1
:= Chars
(State_Id
);
26394 ("constituent & of state % cannot be used in "
26395 & "dependence refinement", N
, Constit_Id
);
26396 Error_Msg_Name_1
:= Chars
(State_Id
);
26397 SPARK_Msg_N
("\use state % instead", N
);
26400 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26402 elsif Present
(Body_Inputs
)
26403 and then Appears_In
(Body_Inputs
, Constit_Id
)
26405 Error_Msg_Name_1
:= Chars
(State_Id
);
26407 ("constituent & of state % must act as output in "
26408 & "dependence refinement", N
, Constit_Id
);
26410 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26412 elsif No
(Body_Outputs
)
26413 or else not Appears_In
(Body_Outputs
, Constit_Id
)
26418 ("output state & must be replaced by all its "
26419 & "constituents in dependence refinement",
26424 ("\constituent & is missing in output list",
26428 Next_Elmt
(Constit_Elmt
);
26431 end Check_Constituent_Usage
;
26436 Item_Elmt
: Elmt_Id
;
26437 Item_Id
: Entity_Id
;
26439 -- Start of processing for Check_Output_States
26442 -- Do not perform this check in an instance because it was already
26443 -- performed successfully in the generic template.
26445 if Is_Generic_Instance
(Spec_Id
) then
26448 -- Inspect the outputs of pragma Depends looking for a state with a
26449 -- visible refinement.
26451 elsif Present
(Spec_Outputs
) then
26452 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
26453 while Present
(Item_Elmt
) loop
26454 Item
:= Node
(Item_Elmt
);
26456 -- Deal with the mixed nature of the input and output lists
26458 if Nkind
(Item
) = N_Defining_Identifier
then
26461 Item_Id
:= Available_View
(Entity_Of
(Item
));
26464 if Ekind
(Item_Id
) = E_Abstract_State
then
26466 -- The state acts as an input-output, skip it
26468 if Present
(Spec_Inputs
)
26469 and then Appears_In
(Spec_Inputs
, Item_Id
)
26473 -- Ensure that all of the constituents are utilized as
26474 -- outputs in pragma Refined_Depends.
26476 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26477 Check_Constituent_Usage
(Item_Id
);
26481 Next_Elmt
(Item_Elmt
);
26484 end Check_Output_States
;
26486 --------------------
26487 -- Collect_States --
26488 --------------------
26490 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
26491 procedure Collect_State
26493 States
: in out Elist_Id
);
26494 -- Add the entity of Item to list States when it denotes to a state
26496 -------------------
26497 -- Collect_State --
26498 -------------------
26500 procedure Collect_State
26502 States
: in out Elist_Id
)
26507 if Is_Entity_Name
(Item
) then
26508 Id
:= Entity_Of
(Item
);
26510 if Ekind
(Id
) = E_Abstract_State
then
26511 if No
(States
) then
26512 States
:= New_Elmt_List
;
26515 Append_Unique_Elmt
(Id
, States
);
26525 States
: Elist_Id
:= No_Elist
;
26527 -- Start of processing for Collect_States
26530 Clause
:= First
(Clauses
);
26531 while Present
(Clause
) loop
26532 Input
:= Expression
(Clause
);
26533 Output
:= First
(Choices
(Clause
));
26535 Collect_State
(Input
, States
);
26536 Collect_State
(Output
, States
);
26542 end Collect_States
;
26544 -----------------------
26545 -- Normalize_Clauses --
26546 -----------------------
26548 procedure Normalize_Clauses
(Clauses
: List_Id
) is
26549 procedure Normalize_Inputs
(Clause
: Node_Id
);
26550 -- Normalize clause Clause by creating multiple clauses for each
26551 -- input item of Clause. It is assumed that Clause has exactly one
26552 -- output. The transformation is as follows:
26554 -- Output => (Input_1, Input_2) -- original
26556 -- Output => Input_1 -- normalizations
26557 -- Output => Input_2
26559 procedure Normalize_Outputs
(Clause
: Node_Id
);
26560 -- Normalize clause Clause by creating multiple clause for each
26561 -- output item of Clause. The transformation is as follows:
26563 -- (Output_1, Output_2) => Input -- original
26565 -- Output_1 => Input -- normalization
26566 -- Output_2 => Input
26568 ----------------------
26569 -- Normalize_Inputs --
26570 ----------------------
26572 procedure Normalize_Inputs
(Clause
: Node_Id
) is
26573 Inputs
: constant Node_Id
:= Expression
(Clause
);
26574 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26575 Output
: constant List_Id
:= Choices
(Clause
);
26576 Last_Input
: Node_Id
;
26578 New_Clause
: Node_Id
;
26579 Next_Input
: Node_Id
;
26582 -- Normalization is performed only when the original clause has
26583 -- more than one input. Multiple inputs appear as an aggregate.
26585 if Nkind
(Inputs
) = N_Aggregate
then
26586 Last_Input
:= Last
(Expressions
(Inputs
));
26588 -- Create a new clause for each input
26590 Input
:= First
(Expressions
(Inputs
));
26591 while Present
(Input
) loop
26592 Next_Input
:= Next
(Input
);
26594 -- Unhook the current input from the original input list
26595 -- because it will be relocated to a new clause.
26599 -- Special processing for the last input. At this point the
26600 -- original aggregate has been stripped down to one element.
26601 -- Replace the aggregate by the element itself.
26603 if Input
= Last_Input
then
26604 Rewrite
(Inputs
, Input
);
26606 -- Generate a clause of the form:
26611 Make_Component_Association
(Loc
,
26612 Choices
=> New_Copy_List_Tree
(Output
),
26613 Expression
=> Input
);
26615 -- The new clause contains replicated content that has
26616 -- already been analyzed, mark the clause as analyzed.
26618 Set_Analyzed
(New_Clause
);
26619 Insert_After
(Clause
, New_Clause
);
26622 Input
:= Next_Input
;
26625 end Normalize_Inputs
;
26627 -----------------------
26628 -- Normalize_Outputs --
26629 -----------------------
26631 procedure Normalize_Outputs
(Clause
: Node_Id
) is
26632 Inputs
: constant Node_Id
:= Expression
(Clause
);
26633 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26634 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
26635 Last_Output
: Node_Id
;
26636 New_Clause
: Node_Id
;
26637 Next_Output
: Node_Id
;
26641 -- Multiple outputs appear as an aggregate. Nothing to do when
26642 -- the clause has exactly one output.
26644 if Nkind
(Outputs
) = N_Aggregate
then
26645 Last_Output
:= Last
(Expressions
(Outputs
));
26647 -- Create a clause for each output. Note that each time a new
26648 -- clause is created, the original output list slowly shrinks
26649 -- until there is one item left.
26651 Output
:= First
(Expressions
(Outputs
));
26652 while Present
(Output
) loop
26653 Next_Output
:= Next
(Output
);
26655 -- Unhook the output from the original output list as it
26656 -- will be relocated to a new clause.
26660 -- Special processing for the last output. At this point
26661 -- the original aggregate has been stripped down to one
26662 -- element. Replace the aggregate by the element itself.
26664 if Output
= Last_Output
then
26665 Rewrite
(Outputs
, Output
);
26668 -- Generate a clause of the form:
26669 -- (Output => Inputs)
26672 Make_Component_Association
(Loc
,
26673 Choices
=> New_List
(Output
),
26674 Expression
=> New_Copy_Tree
(Inputs
));
26676 -- The new clause contains replicated content that has
26677 -- already been analyzed. There is not need to reanalyze
26680 Set_Analyzed
(New_Clause
);
26681 Insert_After
(Clause
, New_Clause
);
26684 Output
:= Next_Output
;
26687 end Normalize_Outputs
;
26693 -- Start of processing for Normalize_Clauses
26696 Clause
:= First
(Clauses
);
26697 while Present
(Clause
) loop
26698 Normalize_Outputs
(Clause
);
26702 Clause
:= First
(Clauses
);
26703 while Present
(Clause
) loop
26704 Normalize_Inputs
(Clause
);
26707 end Normalize_Clauses
;
26709 --------------------------
26710 -- Remove_Extra_Clauses --
26711 --------------------------
26713 procedure Remove_Extra_Clauses
26714 (Clauses
: List_Id
;
26715 Matched_Items
: Elist_Id
)
26719 Input_Id
: Entity_Id
;
26720 Next_Clause
: Node_Id
;
26722 State_Id
: Entity_Id
;
26725 Clause
:= First
(Clauses
);
26726 while Present
(Clause
) loop
26727 Next_Clause
:= Next
(Clause
);
26729 Input
:= Expression
(Clause
);
26730 Output
:= First
(Choices
(Clause
));
26732 -- Recognize a clause of the form
26736 -- where Input is a constituent of a state which was already
26737 -- successfully matched. This clause must be removed because it
26738 -- simply indicates that some of the constituents of the state
26741 -- Refined_State => (State => (Constit_1, Constit_2))
26742 -- Depends => (Output => State)
26743 -- Refined_Depends => ((Output => Constit_1), -- State matched
26744 -- (null => Constit_2)) -- OK
26746 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
26748 -- Handle abstract views generated for limited with clauses
26750 Input_Id
:= Available_View
(Entity_Of
(Input
));
26752 -- The input must be a constituent of a state
26754 if Ekind_In
(Input_Id
, E_Abstract_State
,
26757 and then Present
(Encapsulating_State
(Input_Id
))
26759 State_Id
:= Encapsulating_State
(Input_Id
);
26761 -- The state must have a non-null visible refinement and be
26762 -- matched in a previous clause.
26764 if Has_Non_Null_Visible_Refinement
(State_Id
)
26765 and then Contains
(Matched_Items
, State_Id
)
26771 -- Recognize a clause of the form
26775 -- where Output is an arbitrary item. This clause must be removed
26776 -- because a null input legitimately matches anything.
26778 elsif Nkind
(Input
) = N_Null
then
26782 Clause
:= Next_Clause
;
26784 end Remove_Extra_Clauses
;
26786 --------------------------
26787 -- Report_Extra_Clauses --
26788 --------------------------
26790 procedure Report_Extra_Clauses
26791 (Spec_Id
: Entity_Id
;
26797 -- Do not perform this check in an instance because it was already
26798 -- performed successfully in the generic template.
26800 if Is_Generic_Instance
(Spec_Id
) then
26803 elsif Present
(Clauses
) then
26804 Clause
:= First
(Clauses
);
26805 while Present
(Clause
) loop
26807 ("unmatched or extra clause in dependence refinement",
26813 end Report_Extra_Clauses
;
26817 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26818 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26819 Errors
: constant Nat
:= Serious_Errors_Detected
;
26826 Body_Inputs
: Elist_Id
:= No_Elist
;
26827 Body_Outputs
: Elist_Id
:= No_Elist
;
26828 -- The inputs and outputs of the subprogram body synthesized from pragma
26829 -- Refined_Depends.
26831 Dependencies
: List_Id
:= No_List
;
26833 -- The corresponding Depends pragma along with its clauses
26835 Matched_Items
: Elist_Id
:= No_Elist
;
26836 -- A list containing the entities of all successfully matched items
26837 -- found in pragma Depends.
26839 Refinements
: List_Id
:= No_List
;
26840 -- The clauses of pragma Refined_Depends
26842 Spec_Id
: Entity_Id
;
26843 -- The entity of the subprogram subject to pragma Refined_Depends
26845 Spec_Inputs
: Elist_Id
:= No_Elist
;
26846 Spec_Outputs
: Elist_Id
:= No_Elist
;
26847 -- The inputs and outputs of the subprogram spec synthesized from pragma
26850 States
: Elist_Id
:= No_Elist
;
26851 -- A list containing the entities of all states whose constituents
26852 -- appear in pragma Depends.
26854 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26857 -- Do not analyze the pragma multiple times
26859 if Is_Analyzed_Pragma
(N
) then
26863 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26865 -- Use the anonymous object as the proper spec when Refined_Depends
26866 -- applies to the body of a single task type. The object carries the
26867 -- proper Chars as well as all non-refined versions of pragmas.
26869 if Is_Single_Concurrent_Type
(Spec_Id
) then
26870 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26873 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26875 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26876 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26878 if No
(Depends
) then
26880 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26881 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
26885 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26887 -- A null dependency relation renders the refinement useless because it
26888 -- cannot possibly mention abstract states with visible refinement. Note
26889 -- that the inverse is not true as states may be refined to null
26890 -- (SPARK RM 7.2.5(2)).
26892 if Nkind
(Deps
) = N_Null
then
26894 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26895 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
26899 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26900 -- This ensures that the categorization of all refined dependency items
26901 -- is consistent with their role.
26903 Analyze_Depends_In_Decl_Part
(N
);
26905 -- Do not match dependencies against refinements if Refined_Depends is
26906 -- illegal to avoid emitting misleading error.
26908 if Serious_Errors_Detected
= Errors
then
26910 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26911 -- the inputs and outputs of the subprogram spec and body to verify
26912 -- the use of states with visible refinement and their constituents.
26914 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
26915 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
26917 Collect_Subprogram_Inputs_Outputs
26918 (Subp_Id
=> Spec_Id
,
26919 Synthesize
=> True,
26920 Subp_Inputs
=> Spec_Inputs
,
26921 Subp_Outputs
=> Spec_Outputs
,
26922 Global_Seen
=> Dummy
);
26924 Collect_Subprogram_Inputs_Outputs
26925 (Subp_Id
=> Body_Id
,
26926 Synthesize
=> True,
26927 Subp_Inputs
=> Body_Inputs
,
26928 Subp_Outputs
=> Body_Outputs
,
26929 Global_Seen
=> Dummy
);
26931 -- For an output state with a visible refinement, ensure that all
26932 -- constituents appear as outputs in the dependency refinement.
26934 Check_Output_States
26935 (Spec_Id
=> Spec_Id
,
26936 Spec_Inputs
=> Spec_Inputs
,
26937 Spec_Outputs
=> Spec_Outputs
,
26938 Body_Inputs
=> Body_Inputs
,
26939 Body_Outputs
=> Body_Outputs
);
26942 -- Matching is disabled in ASIS because clauses are not normalized as
26943 -- this is a tree altering activity similar to expansion.
26949 -- Multiple dependency clauses appear as component associations of an
26950 -- aggregate. Note that the clauses are copied because the algorithm
26951 -- modifies them and this should not be visible in Depends.
26953 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
26954 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
26955 Normalize_Clauses
(Dependencies
);
26957 -- Gather all states which appear in Depends
26959 States
:= Collect_States
(Dependencies
);
26961 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
26963 if Nkind
(Refs
) = N_Null
then
26964 Refinements
:= No_List
;
26966 -- Multiple dependency clauses appear as component associations of an
26967 -- aggregate. Note that the clauses are copied because the algorithm
26968 -- modifies them and this should not be visible in Refined_Depends.
26970 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
26971 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
26972 Normalize_Clauses
(Refinements
);
26975 -- At this point the clauses of pragmas Depends and Refined_Depends
26976 -- have been normalized into simple dependencies between one output
26977 -- and one input. Examine all clauses of pragma Depends looking for
26978 -- matching clauses in pragma Refined_Depends.
26980 Clause
:= First
(Dependencies
);
26981 while Present
(Clause
) loop
26982 Check_Dependency_Clause
26983 (Spec_Id
=> Spec_Id
,
26984 Dep_Clause
=> Clause
,
26985 Dep_States
=> States
,
26986 Refinements
=> Refinements
,
26987 Matched_Items
=> Matched_Items
);
26992 -- Pragma Refined_Depends may contain multiple clarification clauses
26993 -- which indicate that certain constituents do not influence the data
26994 -- flow in any way. Such clauses must be removed as long as the state
26995 -- has been matched, otherwise they will be incorrectly flagged as
26998 -- Refined_State => (State => (Constit_1, Constit_2))
26999 -- Depends => (Output => State)
27000 -- Refined_Depends => ((Output => Constit_1), -- State matched
27001 -- (null => Constit_2)) -- must be removed
27003 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
27005 if Serious_Errors_Detected
= Errors
then
27006 Report_Extra_Clauses
(Spec_Id
, Refinements
);
27011 Set_Is_Analyzed_Pragma
(N
);
27012 end Analyze_Refined_Depends_In_Decl_Part
;
27014 -----------------------------------------
27015 -- Analyze_Refined_Global_In_Decl_Part --
27016 -----------------------------------------
27018 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
27020 -- The corresponding Global pragma
27022 Has_In_State
: Boolean := False;
27023 Has_In_Out_State
: Boolean := False;
27024 Has_Out_State
: Boolean := False;
27025 Has_Proof_In_State
: Boolean := False;
27026 -- These flags are set when the corresponding Global pragma has a state
27027 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27030 Has_Null_State
: Boolean := False;
27031 -- This flag is set when the corresponding Global pragma has at least
27032 -- one state with a null refinement.
27034 In_Constits
: Elist_Id
:= No_Elist
;
27035 In_Out_Constits
: Elist_Id
:= No_Elist
;
27036 Out_Constits
: Elist_Id
:= No_Elist
;
27037 Proof_In_Constits
: Elist_Id
:= No_Elist
;
27038 -- These lists contain the entities of all Input, In_Out, Output and
27039 -- Proof_In constituents that appear in Refined_Global and participate
27040 -- in state refinement.
27042 In_Items
: Elist_Id
:= No_Elist
;
27043 In_Out_Items
: Elist_Id
:= No_Elist
;
27044 Out_Items
: Elist_Id
:= No_Elist
;
27045 Proof_In_Items
: Elist_Id
:= No_Elist
;
27046 -- These lists contain the entities of all Input, In_Out, Output and
27047 -- Proof_In items defined in the corresponding Global pragma.
27049 Repeat_Items
: Elist_Id
:= No_Elist
;
27050 -- A list of all global items without full visible refinement found
27051 -- in pragma Global. These states should be repeated in the global
27052 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27053 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27055 Spec_Id
: Entity_Id
;
27056 -- The entity of the subprogram subject to pragma Refined_Global
27058 States
: Elist_Id
:= No_Elist
;
27059 -- A list of all states with full or partial visible refinement found in
27062 procedure Check_In_Out_States
;
27063 -- Determine whether the corresponding Global pragma mentions In_Out
27064 -- states with visible refinement and if so, ensure that one of the
27065 -- following completions apply to the constituents of the state:
27066 -- 1) there is at least one constituent of mode In_Out
27067 -- 2) there is at least one Input and one Output constituent
27068 -- 3) not all constituents are present and one of them is of mode
27070 -- This routine may remove elements from In_Constits, In_Out_Constits,
27071 -- Out_Constits and Proof_In_Constits.
27073 procedure Check_Input_States
;
27074 -- Determine whether the corresponding Global pragma mentions Input
27075 -- states with visible refinement and if so, ensure that at least one of
27076 -- its constituents appears as an Input item in Refined_Global.
27077 -- This routine may remove elements from In_Constits, In_Out_Constits,
27078 -- Out_Constits and Proof_In_Constits.
27080 procedure Check_Output_States
;
27081 -- Determine whether the corresponding Global pragma mentions Output
27082 -- states with visible refinement and if so, ensure that all of its
27083 -- constituents appear as Output items in Refined_Global.
27084 -- This routine may remove elements from In_Constits, In_Out_Constits,
27085 -- Out_Constits and Proof_In_Constits.
27087 procedure Check_Proof_In_States
;
27088 -- Determine whether the corresponding Global pragma mentions Proof_In
27089 -- states with visible refinement and if so, ensure that at least one of
27090 -- its constituents appears as a Proof_In item in Refined_Global.
27091 -- This routine may remove elements from In_Constits, In_Out_Constits,
27092 -- Out_Constits and Proof_In_Constits.
27094 procedure Check_Refined_Global_List
27096 Global_Mode
: Name_Id
:= Name_Input
);
27097 -- Verify the legality of a single global list declaration. Global_Mode
27098 -- denotes the current mode in effect.
27100 procedure Collect_Global_Items
27102 Mode
: Name_Id
:= Name_Input
);
27103 -- Gather all Input, In_Out, Output and Proof_In items from node List
27104 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27105 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27106 -- and Has_Proof_In_State are set when there is at least one abstract
27107 -- state with full or partial visible refinement available in the
27108 -- corresponding mode. Flag Has_Null_State is set when at least state
27109 -- has a null refinement. Mode denotes the current global mode in
27112 function Present_Then_Remove
27114 Item
: Entity_Id
) return Boolean;
27115 -- Search List for a particular entity Item. If Item has been found,
27116 -- remove it from List. This routine is used to strip lists In_Constits,
27117 -- In_Out_Constits and Out_Constits of valid constituents.
27119 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
27120 -- Same as function Present_Then_Remove, but do not report the presence
27121 -- of Item in List.
27123 procedure Report_Extra_Constituents
;
27124 -- Emit an error for each constituent found in lists In_Constits,
27125 -- In_Out_Constits and Out_Constits.
27127 procedure Report_Missing_Items
;
27128 -- Emit an error for each global item not repeated found in list
27131 -------------------------
27132 -- Check_In_Out_States --
27133 -------------------------
27135 procedure Check_In_Out_States
is
27136 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27137 -- Determine whether one of the following coverage scenarios is in
27139 -- 1) there is at least one constituent of mode In_Out or Output
27140 -- 2) there is at least one pair of constituents with modes Input
27141 -- and Output, or Proof_In and Output.
27142 -- 3) there is at least one constituent of mode Output and not all
27143 -- constituents are present.
27144 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27146 -----------------------------
27147 -- Check_Constituent_Usage --
27148 -----------------------------
27150 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27151 Constits
: constant Elist_Id
:=
27152 Partial_Refinement_Constituents
(State_Id
);
27153 Constit_Elmt
: Elmt_Id
;
27154 Constit_Id
: Entity_Id
;
27155 Has_Missing
: Boolean := False;
27156 In_Out_Seen
: Boolean := False;
27157 Input_Seen
: Boolean := False;
27158 Output_Seen
: Boolean := False;
27159 Proof_In_Seen
: Boolean := False;
27162 -- Process all the constituents of the state and note their modes
27163 -- within the global refinement.
27165 if Present
(Constits
) then
27166 Constit_Elmt
:= First_Elmt
(Constits
);
27167 while Present
(Constit_Elmt
) loop
27168 Constit_Id
:= Node
(Constit_Elmt
);
27170 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27171 Input_Seen
:= True;
27173 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
27174 In_Out_Seen
:= True;
27176 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27177 Output_Seen
:= True;
27179 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27181 Proof_In_Seen
:= True;
27184 Has_Missing
:= True;
27187 Next_Elmt
(Constit_Elmt
);
27191 -- An In_Out constituent is a valid completion
27193 if In_Out_Seen
then
27196 -- A pair of one Input/Proof_In and one Output constituent is a
27197 -- valid completion.
27199 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
27202 elsif Output_Seen
then
27204 -- A single Output constituent is a valid completion only when
27205 -- some of the other constituents are missing.
27207 if Has_Missing
then
27210 -- Otherwise all constituents are of mode Output
27214 ("global refinement of state & must include at least one "
27215 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27219 -- The state lacks a completion. When full refinement is visible,
27220 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27221 -- refinement is visible, emit an error if the abstract state
27222 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27223 -- both are utilized, Check_State_And_Constituent_Use. will issue
27226 elsif not Input_Seen
27227 and then not In_Out_Seen
27228 and then not Output_Seen
27229 and then not Proof_In_Seen
27231 if Has_Visible_Refinement
(State_Id
)
27232 or else Contains
(Repeat_Items
, State_Id
)
27235 ("missing global refinement of state &", N
, State_Id
);
27238 -- Otherwise the state has a malformed completion where at least
27239 -- one of the constituents has a different mode.
27243 ("global refinement of state & redefines the mode of its "
27244 & "constituents", N
, State_Id
);
27246 end Check_Constituent_Usage
;
27250 Item_Elmt
: Elmt_Id
;
27251 Item_Id
: Entity_Id
;
27253 -- Start of processing for Check_In_Out_States
27256 -- Do not perform this check in an instance because it was already
27257 -- performed successfully in the generic template.
27259 if Is_Generic_Instance
(Spec_Id
) then
27262 -- Inspect the In_Out items of the corresponding Global pragma
27263 -- looking for a state with a visible refinement.
27265 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
27266 Item_Elmt
:= First_Elmt
(In_Out_Items
);
27267 while Present
(Item_Elmt
) loop
27268 Item_Id
:= Node
(Item_Elmt
);
27270 -- Ensure that one of the three coverage variants is satisfied
27272 if Ekind
(Item_Id
) = E_Abstract_State
27273 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27275 Check_Constituent_Usage
(Item_Id
);
27278 Next_Elmt
(Item_Elmt
);
27281 end Check_In_Out_States
;
27283 ------------------------
27284 -- Check_Input_States --
27285 ------------------------
27287 procedure Check_Input_States
is
27288 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27289 -- Determine whether at least one constituent of state State_Id with
27290 -- full or partial visible refinement is used and has mode Input.
27291 -- Ensure that the remaining constituents do not have In_Out or
27292 -- Output modes. Emit an error if this is not the case
27293 -- (SPARK RM 7.2.4(5)).
27295 -----------------------------
27296 -- Check_Constituent_Usage --
27297 -----------------------------
27299 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27300 Constits
: constant Elist_Id
:=
27301 Partial_Refinement_Constituents
(State_Id
);
27302 Constit_Elmt
: Elmt_Id
;
27303 Constit_Id
: Entity_Id
;
27304 In_Seen
: Boolean := False;
27307 if Present
(Constits
) then
27308 Constit_Elmt
:= First_Elmt
(Constits
);
27309 while Present
(Constit_Elmt
) loop
27310 Constit_Id
:= Node
(Constit_Elmt
);
27312 -- At least one of the constituents appears as an Input
27314 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27317 -- A Proof_In constituent can refine an Input state as long
27318 -- as there is at least one Input constituent present.
27320 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27324 -- The constituent appears in the global refinement, but has
27325 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27327 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27328 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27330 Error_Msg_Name_1
:= Chars
(State_Id
);
27332 ("constituent & of state % must have mode `Input` in "
27333 & "global refinement", N
, Constit_Id
);
27336 Next_Elmt
(Constit_Elmt
);
27340 -- Not one of the constituents appeared as Input. Always emit an
27341 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27342 -- When only partial refinement is visible, emit an error if the
27343 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27344 -- the case where both are utilized, an error will be issued in
27345 -- Check_State_And_Constituent_Use.
27348 and then (Has_Visible_Refinement
(State_Id
)
27349 or else Contains
(Repeat_Items
, State_Id
))
27352 ("global refinement of state & must include at least one "
27353 & "constituent of mode `Input`", N
, State_Id
);
27355 end Check_Constituent_Usage
;
27359 Item_Elmt
: Elmt_Id
;
27360 Item_Id
: Entity_Id
;
27362 -- Start of processing for Check_Input_States
27365 -- Do not perform this check in an instance because it was already
27366 -- performed successfully in the generic template.
27368 if Is_Generic_Instance
(Spec_Id
) then
27371 -- Inspect the Input items of the corresponding Global pragma looking
27372 -- for a state with a visible refinement.
27374 elsif Has_In_State
and then Present
(In_Items
) then
27375 Item_Elmt
:= First_Elmt
(In_Items
);
27376 while Present
(Item_Elmt
) loop
27377 Item_Id
:= Node
(Item_Elmt
);
27379 -- When full refinement is visible, ensure that at least one of
27380 -- the constituents is utilized and is of mode Input. When only
27381 -- partial refinement is visible, ensure that either one of
27382 -- the constituents is utilized and is of mode Input, or the
27383 -- abstract state is repeated and no constituent is utilized.
27385 if Ekind
(Item_Id
) = E_Abstract_State
27386 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27388 Check_Constituent_Usage
(Item_Id
);
27391 Next_Elmt
(Item_Elmt
);
27394 end Check_Input_States
;
27396 -------------------------
27397 -- Check_Output_States --
27398 -------------------------
27400 procedure Check_Output_States
is
27401 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27402 -- Determine whether all constituents of state State_Id with full
27403 -- visible refinement are used and have mode Output. Emit an error
27404 -- if this is not the case (SPARK RM 7.2.4(5)).
27406 -----------------------------
27407 -- Check_Constituent_Usage --
27408 -----------------------------
27410 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27411 Constits
: constant Elist_Id
:=
27412 Partial_Refinement_Constituents
(State_Id
);
27413 Only_Partial
: constant Boolean :=
27414 not Has_Visible_Refinement
(State_Id
);
27415 Constit_Elmt
: Elmt_Id
;
27416 Constit_Id
: Entity_Id
;
27417 Posted
: Boolean := False;
27420 if Present
(Constits
) then
27421 Constit_Elmt
:= First_Elmt
(Constits
);
27422 while Present
(Constit_Elmt
) loop
27423 Constit_Id
:= Node
(Constit_Elmt
);
27425 -- Issue an error when a constituent of State_Id is utilized
27426 -- and State_Id has only partial visible refinement
27427 -- (SPARK RM 7.2.4(3d)).
27429 if Only_Partial
then
27430 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
27431 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
27433 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27435 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27437 Error_Msg_Name_1
:= Chars
(State_Id
);
27439 ("constituent & of state % cannot be used in global "
27440 & "refinement", N
, Constit_Id
);
27441 Error_Msg_Name_1
:= Chars
(State_Id
);
27442 SPARK_Msg_N
("\use state % instead", N
);
27445 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27448 -- The constituent appears in the global refinement, but has
27449 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27451 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27452 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27453 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27455 Error_Msg_Name_1
:= Chars
(State_Id
);
27457 ("constituent & of state % must have mode `Output` in "
27458 & "global refinement", N
, Constit_Id
);
27460 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27466 ("`Output` state & must be replaced by all its "
27467 & "constituents in global refinement", N
, State_Id
);
27471 ("\constituent & is missing in output list",
27475 Next_Elmt
(Constit_Elmt
);
27478 end Check_Constituent_Usage
;
27482 Item_Elmt
: Elmt_Id
;
27483 Item_Id
: Entity_Id
;
27485 -- Start of processing for Check_Output_States
27488 -- Do not perform this check in an instance because it was already
27489 -- performed successfully in the generic template.
27491 if Is_Generic_Instance
(Spec_Id
) then
27494 -- Inspect the Output items of the corresponding Global pragma
27495 -- looking for a state with a visible refinement.
27497 elsif Has_Out_State
and then Present
(Out_Items
) then
27498 Item_Elmt
:= First_Elmt
(Out_Items
);
27499 while Present
(Item_Elmt
) loop
27500 Item_Id
:= Node
(Item_Elmt
);
27502 -- When full refinement is visible, ensure that all of the
27503 -- constituents are utilized and they have mode Output. When
27504 -- only partial refinement is visible, ensure that no
27505 -- constituent is utilized.
27507 if Ekind
(Item_Id
) = E_Abstract_State
27508 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27510 Check_Constituent_Usage
(Item_Id
);
27513 Next_Elmt
(Item_Elmt
);
27516 end Check_Output_States
;
27518 ---------------------------
27519 -- Check_Proof_In_States --
27520 ---------------------------
27522 procedure Check_Proof_In_States
is
27523 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27524 -- Determine whether at least one constituent of state State_Id with
27525 -- full or partial visible refinement is used and has mode Proof_In.
27526 -- Ensure that the remaining constituents do not have Input, In_Out,
27527 -- or Output modes. Emit an error if this is not the case
27528 -- (SPARK RM 7.2.4(5)).
27530 -----------------------------
27531 -- Check_Constituent_Usage --
27532 -----------------------------
27534 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27535 Constits
: constant Elist_Id
:=
27536 Partial_Refinement_Constituents
(State_Id
);
27537 Constit_Elmt
: Elmt_Id
;
27538 Constit_Id
: Entity_Id
;
27539 Proof_In_Seen
: Boolean := False;
27542 if Present
(Constits
) then
27543 Constit_Elmt
:= First_Elmt
(Constits
);
27544 while Present
(Constit_Elmt
) loop
27545 Constit_Id
:= Node
(Constit_Elmt
);
27547 -- At least one of the constituents appears as Proof_In
27549 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
27550 Proof_In_Seen
:= True;
27552 -- The constituent appears in the global refinement, but has
27553 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27555 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27556 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27557 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27559 Error_Msg_Name_1
:= Chars
(State_Id
);
27561 ("constituent & of state % must have mode `Proof_In` "
27562 & "in global refinement", N
, Constit_Id
);
27565 Next_Elmt
(Constit_Elmt
);
27569 -- Not one of the constituents appeared as Proof_In. Always emit
27570 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27571 -- When only partial refinement is visible, emit an error if the
27572 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27573 -- the case where both are utilized, an error will be issued by
27574 -- Check_State_And_Constituent_Use.
27576 if not Proof_In_Seen
27577 and then (Has_Visible_Refinement
(State_Id
)
27578 or else Contains
(Repeat_Items
, State_Id
))
27581 ("global refinement of state & must include at least one "
27582 & "constituent of mode `Proof_In`", N
, State_Id
);
27584 end Check_Constituent_Usage
;
27588 Item_Elmt
: Elmt_Id
;
27589 Item_Id
: Entity_Id
;
27591 -- Start of processing for Check_Proof_In_States
27594 -- Do not perform this check in an instance because it was already
27595 -- performed successfully in the generic template.
27597 if Is_Generic_Instance
(Spec_Id
) then
27600 -- Inspect the Proof_In items of the corresponding Global pragma
27601 -- looking for a state with a visible refinement.
27603 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
27604 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
27605 while Present
(Item_Elmt
) loop
27606 Item_Id
:= Node
(Item_Elmt
);
27608 -- Ensure that at least one of the constituents is utilized
27609 -- and is of mode Proof_In. When only partial refinement is
27610 -- visible, ensure that either one of the constituents is
27611 -- utilized and is of mode Proof_In, or the abstract state
27612 -- is repeated and no constituent is utilized.
27614 if Ekind
(Item_Id
) = E_Abstract_State
27615 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27617 Check_Constituent_Usage
(Item_Id
);
27620 Next_Elmt
(Item_Elmt
);
27623 end Check_Proof_In_States
;
27625 -------------------------------
27626 -- Check_Refined_Global_List --
27627 -------------------------------
27629 procedure Check_Refined_Global_List
27631 Global_Mode
: Name_Id
:= Name_Input
)
27633 procedure Check_Refined_Global_Item
27635 Global_Mode
: Name_Id
);
27636 -- Verify the legality of a single global item declaration. Parameter
27637 -- Global_Mode denotes the current mode in effect.
27639 -------------------------------
27640 -- Check_Refined_Global_Item --
27641 -------------------------------
27643 procedure Check_Refined_Global_Item
27645 Global_Mode
: Name_Id
)
27647 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
27649 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
27650 -- Issue a common error message for all mode mismatches. Expect
27651 -- denotes the expected mode.
27653 -----------------------------
27654 -- Inconsistent_Mode_Error --
27655 -----------------------------
27657 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
27660 ("global item & has inconsistent modes", Item
, Item_Id
);
27662 Error_Msg_Name_1
:= Global_Mode
;
27663 Error_Msg_Name_2
:= Expect
;
27664 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
27665 end Inconsistent_Mode_Error
;
27669 Enc_State
: Entity_Id
:= Empty
;
27670 -- Encapsulating state for constituent, Empty otherwise
27672 -- Start of processing for Check_Refined_Global_Item
27675 if Ekind_In
(Item_Id
, E_Abstract_State
,
27679 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
27682 -- When the state or object acts as a constituent of another
27683 -- state with a visible refinement, collect it for the state
27684 -- completeness checks performed later on. Note that the item
27685 -- acts as a constituent only when the encapsulating state is
27686 -- present in pragma Global.
27688 if Present
(Enc_State
)
27689 and then (Has_Visible_Refinement
(Enc_State
)
27690 or else Has_Partial_Visible_Refinement
(Enc_State
))
27691 and then Contains
(States
, Enc_State
)
27693 -- If the state has only partial visible refinement, remove it
27694 -- from the list of items that should be repeated from pragma
27697 if not Has_Visible_Refinement
(Enc_State
) then
27698 Present_Then_Remove
(Repeat_Items
, Enc_State
);
27701 if Global_Mode
= Name_Input
then
27702 Append_New_Elmt
(Item_Id
, In_Constits
);
27704 elsif Global_Mode
= Name_In_Out
then
27705 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
27707 elsif Global_Mode
= Name_Output
then
27708 Append_New_Elmt
(Item_Id
, Out_Constits
);
27710 elsif Global_Mode
= Name_Proof_In
then
27711 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
27714 -- When not a constituent, ensure that both occurrences of the
27715 -- item in pragmas Global and Refined_Global match. Also remove
27716 -- it when present from the list of items that should be repeated
27717 -- from pragma Global.
27720 Present_Then_Remove
(Repeat_Items
, Item_Id
);
27722 if Contains
(In_Items
, Item_Id
) then
27723 if Global_Mode
/= Name_Input
then
27724 Inconsistent_Mode_Error
(Name_Input
);
27727 elsif Contains
(In_Out_Items
, Item_Id
) then
27728 if Global_Mode
/= Name_In_Out
then
27729 Inconsistent_Mode_Error
(Name_In_Out
);
27732 elsif Contains
(Out_Items
, Item_Id
) then
27733 if Global_Mode
/= Name_Output
then
27734 Inconsistent_Mode_Error
(Name_Output
);
27737 elsif Contains
(Proof_In_Items
, Item_Id
) then
27740 -- The item does not appear in the corresponding Global pragma,
27741 -- it must be an extra (SPARK RM 7.2.4(3)).
27744 pragma Assert
(Present
(Global
));
27745 Error_Msg_Sloc
:= Sloc
(Global
);
27746 SPARK_Msg_NE
("extra global item & does not refine or " &
27747 "repeat any global item #", Item
, Item_Id
);
27750 end Check_Refined_Global_Item
;
27756 -- Start of processing for Check_Refined_Global_List
27759 -- Do not perform this check in an instance because it was already
27760 -- performed successfully in the generic template.
27762 if Is_Generic_Instance
(Spec_Id
) then
27765 elsif Nkind
(List
) = N_Null
then
27768 -- Single global item declaration
27770 elsif Nkind_In
(List
, N_Expanded_Name
,
27772 N_Selected_Component
)
27774 Check_Refined_Global_Item
(List
, Global_Mode
);
27776 -- Simple global list or moded global list declaration
27778 elsif Nkind
(List
) = N_Aggregate
then
27780 -- The declaration of a simple global list appear as a collection
27783 if Present
(Expressions
(List
)) then
27784 Item
:= First
(Expressions
(List
));
27785 while Present
(Item
) loop
27786 Check_Refined_Global_Item
(Item
, Global_Mode
);
27790 -- The declaration of a moded global list appears as a collection
27791 -- of component associations where individual choices denote
27794 elsif Present
(Component_Associations
(List
)) then
27795 Item
:= First
(Component_Associations
(List
));
27796 while Present
(Item
) loop
27797 Check_Refined_Global_List
27798 (List
=> Expression
(Item
),
27799 Global_Mode
=> Chars
(First
(Choices
(Item
))));
27807 raise Program_Error
;
27813 raise Program_Error
;
27815 end Check_Refined_Global_List
;
27817 --------------------------
27818 -- Collect_Global_Items --
27819 --------------------------
27821 procedure Collect_Global_Items
27823 Mode
: Name_Id
:= Name_Input
)
27825 procedure Collect_Global_Item
27827 Item_Mode
: Name_Id
);
27828 -- Add a single item to the appropriate list. Item_Mode denotes the
27829 -- current mode in effect.
27831 -------------------------
27832 -- Collect_Global_Item --
27833 -------------------------
27835 procedure Collect_Global_Item
27837 Item_Mode
: Name_Id
)
27839 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
27840 -- The above handles abstract views of variables and states built
27841 -- for limited with clauses.
27844 -- Signal that the global list contains at least one abstract
27845 -- state with a visible refinement. Note that the refinement may
27846 -- be null in which case there are no constituents.
27848 if Ekind
(Item_Id
) = E_Abstract_State
then
27849 if Has_Null_Visible_Refinement
(Item_Id
) then
27850 Has_Null_State
:= True;
27852 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27853 Append_New_Elmt
(Item_Id
, States
);
27855 if Item_Mode
= Name_Input
then
27856 Has_In_State
:= True;
27857 elsif Item_Mode
= Name_In_Out
then
27858 Has_In_Out_State
:= True;
27859 elsif Item_Mode
= Name_Output
then
27860 Has_Out_State
:= True;
27861 elsif Item_Mode
= Name_Proof_In
then
27862 Has_Proof_In_State
:= True;
27867 -- Record global items without full visible refinement found in
27868 -- pragma Global which should be repeated in the global refinement
27869 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27871 if Ekind
(Item_Id
) /= E_Abstract_State
27872 or else not Has_Visible_Refinement
(Item_Id
)
27874 Append_New_Elmt
(Item_Id
, Repeat_Items
);
27877 -- Add the item to the proper list
27879 if Item_Mode
= Name_Input
then
27880 Append_New_Elmt
(Item_Id
, In_Items
);
27881 elsif Item_Mode
= Name_In_Out
then
27882 Append_New_Elmt
(Item_Id
, In_Out_Items
);
27883 elsif Item_Mode
= Name_Output
then
27884 Append_New_Elmt
(Item_Id
, Out_Items
);
27885 elsif Item_Mode
= Name_Proof_In
then
27886 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
27888 end Collect_Global_Item
;
27894 -- Start of processing for Collect_Global_Items
27897 if Nkind
(List
) = N_Null
then
27900 -- Single global item declaration
27902 elsif Nkind_In
(List
, N_Expanded_Name
,
27904 N_Selected_Component
)
27906 Collect_Global_Item
(List
, Mode
);
27908 -- Single global list or moded global list declaration
27910 elsif Nkind
(List
) = N_Aggregate
then
27912 -- The declaration of a simple global list appear as a collection
27915 if Present
(Expressions
(List
)) then
27916 Item
:= First
(Expressions
(List
));
27917 while Present
(Item
) loop
27918 Collect_Global_Item
(Item
, Mode
);
27922 -- The declaration of a moded global list appears as a collection
27923 -- of component associations where individual choices denote mode.
27925 elsif Present
(Component_Associations
(List
)) then
27926 Item
:= First
(Component_Associations
(List
));
27927 while Present
(Item
) loop
27928 Collect_Global_Items
27929 (List
=> Expression
(Item
),
27930 Mode
=> Chars
(First
(Choices
(Item
))));
27938 raise Program_Error
;
27941 -- To accommodate partial decoration of disabled SPARK features, this
27942 -- routine may be called with illegal input. If this is the case, do
27943 -- not raise Program_Error.
27948 end Collect_Global_Items
;
27950 -------------------------
27951 -- Present_Then_Remove --
27952 -------------------------
27954 function Present_Then_Remove
27956 Item
: Entity_Id
) return Boolean
27961 if Present
(List
) then
27962 Elmt
:= First_Elmt
(List
);
27963 while Present
(Elmt
) loop
27964 if Node
(Elmt
) = Item
then
27965 Remove_Elmt
(List
, Elmt
);
27974 end Present_Then_Remove
;
27976 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
27979 Ignore
:= Present_Then_Remove
(List
, Item
);
27980 end Present_Then_Remove
;
27982 -------------------------------
27983 -- Report_Extra_Constituents --
27984 -------------------------------
27986 procedure Report_Extra_Constituents
is
27987 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
27988 -- Emit an error for every element of List
27990 ---------------------------------------
27991 -- Report_Extra_Constituents_In_List --
27992 ---------------------------------------
27994 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
27995 Constit_Elmt
: Elmt_Id
;
27998 if Present
(List
) then
27999 Constit_Elmt
:= First_Elmt
(List
);
28000 while Present
(Constit_Elmt
) loop
28001 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
28002 Next_Elmt
(Constit_Elmt
);
28005 end Report_Extra_Constituents_In_List
;
28007 -- Start of processing for Report_Extra_Constituents
28010 -- Do not perform this check in an instance because it was already
28011 -- performed successfully in the generic template.
28013 if Is_Generic_Instance
(Spec_Id
) then
28017 Report_Extra_Constituents_In_List
(In_Constits
);
28018 Report_Extra_Constituents_In_List
(In_Out_Constits
);
28019 Report_Extra_Constituents_In_List
(Out_Constits
);
28020 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
28022 end Report_Extra_Constituents
;
28024 --------------------------
28025 -- Report_Missing_Items --
28026 --------------------------
28028 procedure Report_Missing_Items
is
28029 Item_Elmt
: Elmt_Id
;
28030 Item_Id
: Entity_Id
;
28033 -- Do not perform this check in an instance because it was already
28034 -- performed successfully in the generic template.
28036 if Is_Generic_Instance
(Spec_Id
) then
28040 if Present
(Repeat_Items
) then
28041 Item_Elmt
:= First_Elmt
(Repeat_Items
);
28042 while Present
(Item_Elmt
) loop
28043 Item_Id
:= Node
(Item_Elmt
);
28044 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
28045 Next_Elmt
(Item_Elmt
);
28049 end Report_Missing_Items
;
28053 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28054 Errors
: constant Nat
:= Serious_Errors_Detected
;
28056 No_Constit
: Boolean;
28058 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28061 -- Do not analyze the pragma multiple times
28063 if Is_Analyzed_Pragma
(N
) then
28067 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28069 -- Use the anonymous object as the proper spec when Refined_Global
28070 -- applies to the body of a single task type. The object carries the
28071 -- proper Chars as well as all non-refined versions of pragmas.
28073 if Is_Single_Concurrent_Type
(Spec_Id
) then
28074 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28077 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28078 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
28080 -- The subprogram declaration lacks pragma Global. This renders
28081 -- Refined_Global useless as there is nothing to refine.
28083 if No
(Global
) then
28085 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28086 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
28090 -- Extract all relevant items from the corresponding Global pragma
28092 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28094 -- Package and subprogram bodies are instantiated individually in
28095 -- a separate compiler pass. Due to this mode of instantiation, the
28096 -- refinement of a state may no longer be visible when a subprogram
28097 -- body contract is instantiated. Since the generic template is legal,
28098 -- do not perform this check in the instance to circumvent this oddity.
28100 if Is_Generic_Instance
(Spec_Id
) then
28103 -- Non-instance case
28106 -- The corresponding Global pragma must mention at least one
28107 -- state with a visible refinement at the point Refined_Global
28108 -- is processed. States with null refinements need Refined_Global
28109 -- pragma (SPARK RM 7.2.4(2)).
28111 if not Has_In_State
28112 and then not Has_In_Out_State
28113 and then not Has_Out_State
28114 and then not Has_Proof_In_State
28115 and then not Has_Null_State
28118 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28119 & "depend on abstract state with visible refinement"),
28123 -- The global refinement of inputs and outputs cannot be null when
28124 -- the corresponding Global pragma contains at least one item except
28125 -- in the case where we have states with null refinements.
28127 elsif Nkind
(Items
) = N_Null
28129 (Present
(In_Items
)
28130 or else Present
(In_Out_Items
)
28131 or else Present
(Out_Items
)
28132 or else Present
(Proof_In_Items
))
28133 and then not Has_Null_State
28136 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
28137 & "global items"), N
, Spec_Id
);
28142 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28143 -- This ensures that the categorization of all refined global items is
28144 -- consistent with their role.
28146 Analyze_Global_In_Decl_Part
(N
);
28148 -- Perform all refinement checks with respect to completeness and mode
28151 if Serious_Errors_Detected
= Errors
then
28152 Check_Refined_Global_List
(Items
);
28155 -- Store the information that no constituent is used in the global
28156 -- refinement, prior to calling checking procedures which remove items
28157 -- from the list of constituents.
28161 and then No
(In_Out_Constits
)
28162 and then No
(Out_Constits
)
28163 and then No
(Proof_In_Constits
);
28165 -- For Input states with visible refinement, at least one constituent
28166 -- must be used as an Input in the global refinement.
28168 if Serious_Errors_Detected
= Errors
then
28169 Check_Input_States
;
28172 -- Verify all possible completion variants for In_Out states with
28173 -- visible refinement.
28175 if Serious_Errors_Detected
= Errors
then
28176 Check_In_Out_States
;
28179 -- For Output states with visible refinement, all constituents must be
28180 -- used as Outputs in the global refinement.
28182 if Serious_Errors_Detected
= Errors
then
28183 Check_Output_States
;
28186 -- For Proof_In states with visible refinement, at least one constituent
28187 -- must be used as Proof_In in the global refinement.
28189 if Serious_Errors_Detected
= Errors
then
28190 Check_Proof_In_States
;
28193 -- Emit errors for all constituents that belong to other states with
28194 -- visible refinement that do not appear in Global.
28196 if Serious_Errors_Detected
= Errors
then
28197 Report_Extra_Constituents
;
28200 -- Emit errors for all items in Global that are not repeated in the
28201 -- global refinement and for which there is no full visible refinement
28202 -- and, in the case of states with partial visible refinement, no
28203 -- constituent is mentioned in the global refinement.
28205 if Serious_Errors_Detected
= Errors
then
28206 Report_Missing_Items
;
28209 -- Emit an error if no constituent is used in the global refinement
28210 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28211 -- one may be issued by the checking procedures. Do not perform this
28212 -- check in an instance because it was already performed successfully
28213 -- in the generic template.
28215 if Serious_Errors_Detected
= Errors
28216 and then not Is_Generic_Instance
(Spec_Id
)
28217 and then not Has_Null_State
28218 and then No_Constit
28220 SPARK_Msg_N
("missing refinement", N
);
28224 Set_Is_Analyzed_Pragma
(N
);
28225 end Analyze_Refined_Global_In_Decl_Part
;
28227 ----------------------------------------
28228 -- Analyze_Refined_State_In_Decl_Part --
28229 ----------------------------------------
28231 procedure Analyze_Refined_State_In_Decl_Part
28233 Freeze_Id
: Entity_Id
:= Empty
)
28235 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
28236 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28237 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
28239 Available_States
: Elist_Id
:= No_Elist
;
28240 -- A list of all abstract states defined in the package declaration that
28241 -- are available for refinement. The list is used to report unrefined
28244 Body_States
: Elist_Id
:= No_Elist
;
28245 -- A list of all hidden states that appear in the body of the related
28246 -- package. The list is used to report unused hidden states.
28248 Constituents_Seen
: Elist_Id
:= No_Elist
;
28249 -- A list that contains all constituents processed so far. The list is
28250 -- used to detect multiple uses of the same constituent.
28252 Freeze_Posted
: Boolean := False;
28253 -- A flag that controls the output of a freezing-related error (see use
28256 Refined_States_Seen
: Elist_Id
:= No_Elist
;
28257 -- A list that contains all refined states processed so far. The list is
28258 -- used to detect duplicate refinements.
28260 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
28261 -- Perform full analysis of a single refinement clause
28263 procedure Report_Unrefined_States
(States
: Elist_Id
);
28264 -- Emit errors for all unrefined abstract states found in list States
28266 -------------------------------
28267 -- Analyze_Refinement_Clause --
28268 -------------------------------
28270 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
28271 AR_Constit
: Entity_Id
:= Empty
;
28272 AW_Constit
: Entity_Id
:= Empty
;
28273 ER_Constit
: Entity_Id
:= Empty
;
28274 EW_Constit
: Entity_Id
:= Empty
;
28275 -- The entities of external constituents that contain one of the
28276 -- following enabled properties: Async_Readers, Async_Writers,
28277 -- Effective_Reads and Effective_Writes.
28279 External_Constit_Seen
: Boolean := False;
28280 -- Flag used to mark when at least one external constituent is part
28281 -- of the state refinement.
28283 Non_Null_Seen
: Boolean := False;
28284 Null_Seen
: Boolean := False;
28285 -- Flags used to detect multiple uses of null in a single clause or a
28286 -- mixture of null and non-null constituents.
28288 Part_Of_Constits
: Elist_Id
:= No_Elist
;
28289 -- A list of all candidate constituents subject to indicator Part_Of
28290 -- where the encapsulating state is the current state.
28293 State_Id
: Entity_Id
;
28294 -- The current state being refined
28296 procedure Analyze_Constituent
(Constit
: Node_Id
);
28297 -- Perform full analysis of a single constituent
28299 procedure Check_External_Property
28300 (Prop_Nam
: Name_Id
;
28302 Constit
: Entity_Id
);
28303 -- Determine whether a property denoted by name Prop_Nam is present
28304 -- in the refined state. Emit an error if this is not the case. Flag
28305 -- Enabled should be set when the property applies to the refined
28306 -- state. Constit denotes the constituent (if any) which introduces
28307 -- the property in the refinement.
28309 procedure Match_State
;
28310 -- Determine whether the state being refined appears in list
28311 -- Available_States. Emit an error when attempting to re-refine the
28312 -- state or when the state is not defined in the package declaration,
28313 -- otherwise remove the state from Available_States.
28315 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
28316 -- Emit errors for all unused Part_Of constituents in list Constits
28318 -------------------------
28319 -- Analyze_Constituent --
28320 -------------------------
28322 procedure Analyze_Constituent
(Constit
: Node_Id
) is
28323 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
28324 -- Determine whether constituent Constit denoted by its entity
28325 -- Constit_Id appears in Body_States. Emit an error when the
28326 -- constituent is not a valid hidden state of the related package
28327 -- or when it is used more than once. Otherwise remove the
28328 -- constituent from Body_States.
28330 -----------------------
28331 -- Match_Constituent --
28332 -----------------------
28334 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
28335 procedure Collect_Constituent
;
28336 -- Verify the legality of constituent Constit_Id and add it to
28337 -- the refinements of State_Id.
28339 -------------------------
28340 -- Collect_Constituent --
28341 -------------------------
28343 procedure Collect_Constituent
is
28344 Constits
: Elist_Id
;
28347 -- The Ghost policy in effect at the point of abstract state
28348 -- declaration and constituent must match (SPARK RM 6.9(15))
28350 Check_Ghost_Refinement
28351 (State
, State_Id
, Constit
, Constit_Id
);
28353 -- A synchronized state must be refined by a synchronized
28354 -- object or another synchronized state (SPARK RM 9.6).
28356 if Is_Synchronized_State
(State_Id
)
28357 and then not Is_Synchronized_Object
(Constit_Id
)
28358 and then not Is_Synchronized_State
(Constit_Id
)
28361 ("constituent of synchronized state & must be "
28362 & "synchronized", Constit
, State_Id
);
28365 -- Add the constituent to the list of processed items to aid
28366 -- with the detection of duplicates.
28368 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
28370 -- Collect the constituent in the list of refinement items
28371 -- and establish a relation between the refined state and
28374 Constits
:= Refinement_Constituents
(State_Id
);
28376 if No
(Constits
) then
28377 Constits
:= New_Elmt_List
;
28378 Set_Refinement_Constituents
(State_Id
, Constits
);
28381 Append_Elmt
(Constit_Id
, Constits
);
28382 Set_Encapsulating_State
(Constit_Id
, State_Id
);
28384 -- The state has at least one legal constituent, mark the
28385 -- start of the refinement region. The region ends when the
28386 -- body declarations end (see routine Analyze_Declarations).
28388 Set_Has_Visible_Refinement
(State_Id
);
28390 -- When the constituent is external, save its relevant
28391 -- property for further checks.
28393 if Async_Readers_Enabled
(Constit_Id
) then
28394 AR_Constit
:= Constit_Id
;
28395 External_Constit_Seen
:= True;
28398 if Async_Writers_Enabled
(Constit_Id
) then
28399 AW_Constit
:= Constit_Id
;
28400 External_Constit_Seen
:= True;
28403 if Effective_Reads_Enabled
(Constit_Id
) then
28404 ER_Constit
:= Constit_Id
;
28405 External_Constit_Seen
:= True;
28408 if Effective_Writes_Enabled
(Constit_Id
) then
28409 EW_Constit
:= Constit_Id
;
28410 External_Constit_Seen
:= True;
28412 end Collect_Constituent
;
28416 State_Elmt
: Elmt_Id
;
28418 -- Start of processing for Match_Constituent
28421 -- Detect a duplicate use of a constituent
28423 if Contains
(Constituents_Seen
, Constit_Id
) then
28425 ("duplicate use of constituent &", Constit
, Constit_Id
);
28429 -- The constituent is subject to a Part_Of indicator
28431 if Present
(Encapsulating_State
(Constit_Id
)) then
28432 if Encapsulating_State
(Constit_Id
) = State_Id
then
28433 Remove
(Part_Of_Constits
, Constit_Id
);
28434 Collect_Constituent
;
28436 -- The constituent is part of another state and is used
28437 -- incorrectly in the refinement of the current state.
28440 Error_Msg_Name_1
:= Chars
(State_Id
);
28442 ("& cannot act as constituent of state %",
28443 Constit
, Constit_Id
);
28445 ("\Part_Of indicator specifies encapsulator &",
28446 Constit
, Encapsulating_State
(Constit_Id
));
28449 -- The only other source of legal constituents is the body
28450 -- state space of the related package.
28453 if Present
(Body_States
) then
28454 State_Elmt
:= First_Elmt
(Body_States
);
28455 while Present
(State_Elmt
) loop
28457 -- Consume a valid constituent to signal that it has
28458 -- been encountered.
28460 if Node
(State_Elmt
) = Constit_Id
then
28461 Remove_Elmt
(Body_States
, State_Elmt
);
28462 Collect_Constituent
;
28466 Next_Elmt
(State_Elmt
);
28470 -- At this point it is known that the constituent is not
28471 -- part of the package hidden state and cannot be used in
28472 -- a refinement (SPARK RM 7.2.2(9)).
28474 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28476 ("cannot use & in refinement, constituent is not a hidden "
28477 & "state of package %", Constit
, Constit_Id
);
28479 end Match_Constituent
;
28483 Constit_Id
: Entity_Id
;
28484 Constits
: Elist_Id
;
28486 -- Start of processing for Analyze_Constituent
28489 -- Detect multiple uses of null in a single refinement clause or a
28490 -- mixture of null and non-null constituents.
28492 if Nkind
(Constit
) = N_Null
then
28495 ("multiple null constituents not allowed", Constit
);
28497 elsif Non_Null_Seen
then
28499 ("cannot mix null and non-null constituents", Constit
);
28504 -- Collect the constituent in the list of refinement items
28506 Constits
:= Refinement_Constituents
(State_Id
);
28508 if No
(Constits
) then
28509 Constits
:= New_Elmt_List
;
28510 Set_Refinement_Constituents
(State_Id
, Constits
);
28513 Append_Elmt
(Constit
, Constits
);
28515 -- The state has at least one legal constituent, mark the
28516 -- start of the refinement region. The region ends when the
28517 -- body declarations end (see Analyze_Declarations).
28519 Set_Has_Visible_Refinement
(State_Id
);
28522 -- Non-null constituents
28525 Non_Null_Seen
:= True;
28529 ("cannot mix null and non-null constituents", Constit
);
28533 Resolve_State
(Constit
);
28535 -- Ensure that the constituent denotes a valid state or a
28536 -- whole object (SPARK RM 7.2.2(5)).
28538 if Is_Entity_Name
(Constit
) then
28539 Constit_Id
:= Entity_Of
(Constit
);
28541 -- When a constituent is declared after a subprogram body
28542 -- that caused freezing of the related contract where
28543 -- pragma Refined_State resides, the constituent appears
28544 -- undefined and carries Any_Id as its entity.
28546 -- package body Pack
28547 -- with Refined_State => (State => Constit)
28550 -- with Refined_Global => (Input => Constit)
28558 if Constit_Id
= Any_Id
then
28559 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
28561 -- Emit a specialized info message when the contract of
28562 -- the related package body was "frozen" by another body.
28563 -- Note that it is not possible to precisely identify why
28564 -- the constituent is undefined because it is not visible
28565 -- when pragma Refined_State is analyzed. This message is
28566 -- a reasonable approximation.
28568 if Present
(Freeze_Id
) and then not Freeze_Posted
then
28569 Freeze_Posted
:= True;
28571 Error_Msg_Name_1
:= Chars
(Body_Id
);
28572 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28574 ("body & declared # freezes the contract of %",
28577 ("\all constituents must be declared before body #",
28580 -- A misplaced constituent is a critical error because
28581 -- pragma Refined_Depends or Refined_Global depends on
28582 -- the proper link between a state and a constituent.
28583 -- Stop the compilation, as this leads to a multitude
28584 -- of misleading cascaded errors.
28586 raise Unrecoverable_Error
;
28589 -- The constituent is a valid state or object
28591 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
28595 Match_Constituent
(Constit_Id
);
28597 -- The variable may eventually become a constituent of a
28598 -- single protected/task type. Record the reference now
28599 -- and verify its legality when analyzing the contract of
28600 -- the variable (SPARK RM 9.3).
28602 if Ekind
(Constit_Id
) = E_Variable
then
28603 Record_Possible_Part_Of_Reference
28604 (Var_Id
=> Constit_Id
,
28608 -- Otherwise the constituent is illegal
28612 ("constituent & must denote object or state",
28613 Constit
, Constit_Id
);
28616 -- The constituent is illegal
28619 SPARK_Msg_N
("malformed constituent", Constit
);
28622 end Analyze_Constituent
;
28624 -----------------------------
28625 -- Check_External_Property --
28626 -----------------------------
28628 procedure Check_External_Property
28629 (Prop_Nam
: Name_Id
;
28631 Constit
: Entity_Id
)
28634 -- The property is missing in the declaration of the state, but
28635 -- a constituent is introducing it in the state refinement
28636 -- (SPARK RM 7.2.8(2)).
28638 if not Enabled
and then Present
(Constit
) then
28639 Error_Msg_Name_1
:= Prop_Nam
;
28640 Error_Msg_Name_2
:= Chars
(State_Id
);
28642 ("constituent & introduces external property % in refinement "
28643 & "of state %", State
, Constit
);
28645 Error_Msg_Sloc
:= Sloc
(State_Id
);
28647 ("\property is missing in abstract state declaration #",
28650 end Check_External_Property
;
28656 procedure Match_State
is
28657 State_Elmt
: Elmt_Id
;
28660 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28662 if Contains
(Refined_States_Seen
, State_Id
) then
28664 ("duplicate refinement of state &", State
, State_Id
);
28668 -- Inspect the abstract states defined in the package declaration
28669 -- looking for a match.
28671 State_Elmt
:= First_Elmt
(Available_States
);
28672 while Present
(State_Elmt
) loop
28674 -- A valid abstract state is being refined in the body. Add
28675 -- the state to the list of processed refined states to aid
28676 -- with the detection of duplicate refinements. Remove the
28677 -- state from Available_States to signal that it has already
28680 if Node
(State_Elmt
) = State_Id
then
28681 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
28682 Remove_Elmt
(Available_States
, State_Elmt
);
28686 Next_Elmt
(State_Elmt
);
28689 -- If we get here, we are refining a state that is not defined in
28690 -- the package declaration.
28692 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28694 ("cannot refine state, & is not defined in package %",
28698 --------------------------------
28699 -- Report_Unused_Constituents --
28700 --------------------------------
28702 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
28703 Constit_Elmt
: Elmt_Id
;
28704 Constit_Id
: Entity_Id
;
28705 Posted
: Boolean := False;
28708 if Present
(Constits
) then
28709 Constit_Elmt
:= First_Elmt
(Constits
);
28710 while Present
(Constit_Elmt
) loop
28711 Constit_Id
:= Node
(Constit_Elmt
);
28713 -- Generate an error message of the form:
28715 -- state ... has unused Part_Of constituents
28716 -- abstract state ... defined at ...
28717 -- constant ... defined at ...
28718 -- variable ... defined at ...
28723 ("state & has unused Part_Of constituents",
28727 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
28729 if Ekind
(Constit_Id
) = E_Abstract_State
then
28731 ("\abstract state & defined #", State
, Constit_Id
);
28733 elsif Ekind
(Constit_Id
) = E_Constant
then
28735 ("\constant & defined #", State
, Constit_Id
);
28738 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
28739 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
28742 Next_Elmt
(Constit_Elmt
);
28745 end Report_Unused_Constituents
;
28747 -- Local declarations
28749 Body_Ref
: Node_Id
;
28750 Body_Ref_Elmt
: Elmt_Id
;
28752 Extra_State
: Node_Id
;
28754 -- Start of processing for Analyze_Refinement_Clause
28757 -- A refinement clause appears as a component association where the
28758 -- sole choice is the state and the expressions are the constituents.
28759 -- This is a syntax error, always report.
28761 if Nkind
(Clause
) /= N_Component_Association
then
28762 Error_Msg_N
("malformed state refinement clause", Clause
);
28766 -- Analyze the state name of a refinement clause
28768 State
:= First
(Choices
(Clause
));
28771 Resolve_State
(State
);
28773 -- Ensure that the state name denotes a valid abstract state that is
28774 -- defined in the spec of the related package.
28776 if Is_Entity_Name
(State
) then
28777 State_Id
:= Entity_Of
(State
);
28779 -- When the abstract state is undefined, it appears as Any_Id. Do
28780 -- not continue with the analysis of the clause.
28782 if State_Id
= Any_Id
then
28785 -- Catch any attempts to re-refine a state or refine a state that
28786 -- is not defined in the package declaration.
28788 elsif Ekind
(State_Id
) = E_Abstract_State
then
28792 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
28796 -- References to a state with visible refinement are illegal.
28797 -- When nested packages are involved, detecting such references is
28798 -- tricky because pragma Refined_State is analyzed later than the
28799 -- offending pragma Depends or Global. References that occur in
28800 -- such nested context are stored in a list. Emit errors for all
28801 -- references found in Body_References (SPARK RM 6.1.4(8)).
28803 if Present
(Body_References
(State_Id
)) then
28804 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
28805 while Present
(Body_Ref_Elmt
) loop
28806 Body_Ref
:= Node
(Body_Ref_Elmt
);
28808 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
28809 Error_Msg_Sloc
:= Sloc
(State
);
28810 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
28812 Next_Elmt
(Body_Ref_Elmt
);
28816 -- The state name is illegal. This is a syntax error, always report.
28819 Error_Msg_N
("malformed state name in refinement clause", State
);
28823 -- A refinement clause may only refine one state at a time
28825 Extra_State
:= Next
(State
);
28827 if Present
(Extra_State
) then
28829 ("refinement clause cannot cover multiple states", Extra_State
);
28832 -- Replicate the Part_Of constituents of the refined state because
28833 -- the algorithm will consume items.
28835 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
28837 -- Analyze all constituents of the refinement. Multiple constituents
28838 -- appear as an aggregate.
28840 Constit
:= Expression
(Clause
);
28842 if Nkind
(Constit
) = N_Aggregate
then
28843 if Present
(Component_Associations
(Constit
)) then
28845 ("constituents of refinement clause must appear in "
28846 & "positional form", Constit
);
28848 else pragma Assert
(Present
(Expressions
(Constit
)));
28849 Constit
:= First
(Expressions
(Constit
));
28850 while Present
(Constit
) loop
28851 Analyze_Constituent
(Constit
);
28856 -- Various forms of a single constituent. Note that these may include
28857 -- malformed constituents.
28860 Analyze_Constituent
(Constit
);
28863 -- Verify that external constituents do not introduce new external
28864 -- property in the state refinement (SPARK RM 7.2.8(2)).
28866 if Is_External_State
(State_Id
) then
28867 Check_External_Property
28868 (Prop_Nam
=> Name_Async_Readers
,
28869 Enabled
=> Async_Readers_Enabled
(State_Id
),
28870 Constit
=> AR_Constit
);
28872 Check_External_Property
28873 (Prop_Nam
=> Name_Async_Writers
,
28874 Enabled
=> Async_Writers_Enabled
(State_Id
),
28875 Constit
=> AW_Constit
);
28877 Check_External_Property
28878 (Prop_Nam
=> Name_Effective_Reads
,
28879 Enabled
=> Effective_Reads_Enabled
(State_Id
),
28880 Constit
=> ER_Constit
);
28882 Check_External_Property
28883 (Prop_Nam
=> Name_Effective_Writes
,
28884 Enabled
=> Effective_Writes_Enabled
(State_Id
),
28885 Constit
=> EW_Constit
);
28887 -- When a refined state is not external, it should not have external
28888 -- constituents (SPARK RM 7.2.8(1)).
28890 elsif External_Constit_Seen
then
28892 ("non-external state & cannot contain external constituents in "
28893 & "refinement", State
, State_Id
);
28896 -- Ensure that all Part_Of candidate constituents have been mentioned
28897 -- in the refinement clause.
28899 Report_Unused_Constituents
(Part_Of_Constits
);
28900 end Analyze_Refinement_Clause
;
28902 -----------------------------
28903 -- Report_Unrefined_States --
28904 -----------------------------
28906 procedure Report_Unrefined_States
(States
: Elist_Id
) is
28907 State_Elmt
: Elmt_Id
;
28910 if Present
(States
) then
28911 State_Elmt
:= First_Elmt
(States
);
28912 while Present
(State_Elmt
) loop
28914 ("abstract state & must be refined", Node
(State_Elmt
));
28916 Next_Elmt
(State_Elmt
);
28919 end Report_Unrefined_States
;
28921 -- Local declarations
28923 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
28926 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28929 -- Do not analyze the pragma multiple times
28931 if Is_Analyzed_Pragma
(N
) then
28935 -- Save the scenario for examination by the ABE Processing phase
28937 Record_Elaboration_Scenario
(N
);
28939 -- Replicate the abstract states declared by the package because the
28940 -- matching algorithm will consume states.
28942 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
28944 -- Gather all abstract states and objects declared in the visible
28945 -- state space of the package body. These items must be utilized as
28946 -- constituents in a state refinement.
28948 Body_States
:= Collect_Body_States
(Body_Id
);
28950 -- Multiple non-null state refinements appear as an aggregate
28952 if Nkind
(Clauses
) = N_Aggregate
then
28953 if Present
(Expressions
(Clauses
)) then
28955 ("state refinements must appear as component associations",
28958 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
28959 Clause
:= First
(Component_Associations
(Clauses
));
28960 while Present
(Clause
) loop
28961 Analyze_Refinement_Clause
(Clause
);
28966 -- Various forms of a single state refinement. Note that these may
28967 -- include malformed refinements.
28970 Analyze_Refinement_Clause
(Clauses
);
28973 -- List all abstract states that were left unrefined
28975 Report_Unrefined_States
(Available_States
);
28977 Set_Is_Analyzed_Pragma
(N
);
28978 end Analyze_Refined_State_In_Decl_Part
;
28980 ------------------------------------
28981 -- Analyze_Test_Case_In_Decl_Part --
28982 ------------------------------------
28984 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
28985 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28986 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28988 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
28989 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28990 -- denoted by Arg_Nam.
28992 ------------------------------
28993 -- Preanalyze_Test_Case_Arg --
28994 ------------------------------
28996 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
29000 -- Preanalyze the original aspect argument for ASIS or for a generic
29001 -- subprogram to properly capture global references.
29003 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
29007 Arg_Nam
=> Arg_Nam
,
29008 From_Aspect
=> True);
29010 if Present
(Arg
) then
29011 Preanalyze_Assert_Expression
29012 (Expression
(Arg
), Standard_Boolean
);
29016 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
29018 if Present
(Arg
) then
29019 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
29021 end Preanalyze_Test_Case_Arg
;
29025 Restore_Scope
: Boolean := False;
29027 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29030 -- Do not analyze the pragma multiple times
29032 if Is_Analyzed_Pragma
(N
) then
29036 -- Ensure that the formal parameters are visible when analyzing all
29037 -- clauses. This falls out of the general rule of aspects pertaining
29038 -- to subprogram declarations.
29040 if not In_Open_Scopes
(Spec_Id
) then
29041 Restore_Scope
:= True;
29042 Push_Scope
(Spec_Id
);
29044 if Is_Generic_Subprogram
(Spec_Id
) then
29045 Install_Generic_Formals
(Spec_Id
);
29047 Install_Formals
(Spec_Id
);
29051 Preanalyze_Test_Case_Arg
(Name_Requires
);
29052 Preanalyze_Test_Case_Arg
(Name_Ensures
);
29054 if Restore_Scope
then
29058 -- Currently it is not possible to inline pre/postconditions on a
29059 -- subprogram subject to pragma Inline_Always.
29061 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
29063 Set_Is_Analyzed_Pragma
(N
);
29064 end Analyze_Test_Case_In_Decl_Part
;
29070 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
29075 if Present
(List
) then
29076 Elmt
:= First_Elmt
(List
);
29077 while Present
(Elmt
) loop
29078 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
29081 Id
:= Entity_Of
(Node
(Elmt
));
29084 if Id
= Item_Id
then
29095 -----------------------------------
29096 -- Build_Pragma_Check_Equivalent --
29097 -----------------------------------
29099 function Build_Pragma_Check_Equivalent
29101 Subp_Id
: Entity_Id
:= Empty
;
29102 Inher_Id
: Entity_Id
:= Empty
;
29103 Keep_Pragma_Id
: Boolean := False) return Node_Id
29105 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
29106 -- Detect whether node N references a formal parameter subject to
29107 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29108 -- to False to suppress the generation of a reference when analyzing
29111 ------------------------
29112 -- Suppress_Reference --
29113 ------------------------
29115 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
29116 Formal
: Entity_Id
;
29119 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29120 Formal
:= Entity
(N
);
29122 -- The formal parameter is subject to pragma Unreferenced. Prevent
29123 -- the generation of references by resetting the Comes_From_Source
29126 if Is_Formal
(Formal
)
29127 and then Has_Pragma_Unreferenced
(Formal
)
29129 Set_Comes_From_Source
(N
, False);
29134 end Suppress_Reference
;
29136 procedure Suppress_References
is
29137 new Traverse_Proc
(Suppress_Reference
);
29141 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
29142 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29143 Check_Prag
: Node_Id
;
29147 Needs_Wrapper
: Boolean;
29148 pragma Unreferenced
(Needs_Wrapper
);
29150 -- Start of processing for Build_Pragma_Check_Equivalent
29153 -- When the pre- or postcondition is inherited, map the formals of the
29154 -- inherited subprogram to those of the current subprogram. In addition,
29155 -- map primitive operations of the parent type into the corresponding
29156 -- primitive operations of the descendant.
29158 if Present
(Inher_Id
) then
29159 pragma Assert
(Present
(Subp_Id
));
29161 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
29163 -- Use generic machinery to copy inherited pragma, as if it were an
29164 -- instantiation, resetting source locations appropriately, so that
29165 -- expressions inside the inherited pragma use chained locations.
29166 -- This is used in particular in GNATprove to locate precisely
29167 -- messages on a given inherited pragma.
29169 Set_Copied_Sloc_For_Inherited_Pragma
29170 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
29171 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29173 -- Build the inherited class-wide condition
29175 Build_Class_Wide_Expression
29176 (Prag
=> Check_Prag
,
29178 Par_Subp
=> Inher_Id
,
29179 Adjust_Sloc
=> True,
29180 Needs_Wrapper
=> Needs_Wrapper
);
29182 -- If not an inherited condition simply copy the original pragma
29185 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29188 -- Mark the pragma as being internally generated and reset the Analyzed
29191 Set_Analyzed
(Check_Prag
, False);
29192 Set_Comes_From_Source
(Check_Prag
, False);
29194 -- The tree of the original pragma may contain references to the
29195 -- formal parameters of the related subprogram. At the same time
29196 -- the corresponding body may mark the formals as unreferenced:
29198 -- procedure Proc (Formal : ...)
29199 -- with Pre => Formal ...;
29201 -- procedure Proc (Formal : ...) is
29202 -- pragma Unreferenced (Formal);
29205 -- This creates problems because all pragma Check equivalents are
29206 -- analyzed at the end of the body declarations. Since all source
29207 -- references have already been accounted for, reset any references
29208 -- to such formals in the generated pragma Check equivalent.
29210 Suppress_References
(Check_Prag
);
29212 if Present
(Corresponding_Aspect
(Prag
)) then
29213 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
29218 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29219 -- the copied pragma in the newly created pragma, convert the copy into
29220 -- pragma Check by correcting the name and adding a check_kind argument.
29222 if not Keep_Pragma_Id
then
29223 Set_Class_Present
(Check_Prag
, False);
29225 Set_Pragma_Identifier
29226 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
29228 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
29229 Make_Pragma_Argument_Association
(Loc
,
29230 Expression
=> Make_Identifier
(Loc
, Nam
)));
29233 -- Update the error message when the pragma is inherited
29235 if Present
(Inher_Id
) then
29236 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
29238 if Chars
(Msg_Arg
) = Name_Message
then
29239 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
29241 -- Insert "inherited" to improve the error message
29243 if Name_Buffer
(1 .. 8) = "failed p" then
29244 Insert_Str_In_Name_Buffer
("inherited ", 8);
29245 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
29251 end Build_Pragma_Check_Equivalent
;
29253 -----------------------------
29254 -- Check_Applicable_Policy --
29255 -----------------------------
29257 procedure Check_Applicable_Policy
(N
: Node_Id
) is
29261 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
29264 -- No effect if not valid assertion kind name
29266 if not Is_Valid_Assertion_Kind
(Ename
) then
29270 -- Loop through entries in check policy list
29272 PP
:= Opt
.Check_Policy_List
;
29273 while Present
(PP
) loop
29275 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29276 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29280 or else Pnm
= Name_Assertion
29281 or else (Pnm
= Name_Statement_Assertions
29282 and then Nam_In
(Ename
, Name_Assert
,
29283 Name_Assert_And_Cut
,
29285 Name_Loop_Invariant
,
29286 Name_Loop_Variant
))
29288 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
29294 -- In CodePeer mode and GNATprove mode, we need to
29295 -- consider all assertions, unless they are disabled.
29296 -- Force Is_Checked on ignored assertions, in particular
29297 -- because transformations of the AST may depend on
29298 -- assertions being checked (e.g. the translation of
29299 -- attribute 'Loop_Entry).
29301 if CodePeer_Mode
or GNATprove_Mode
then
29302 Set_Is_Checked
(N
, True);
29303 Set_Is_Ignored
(N
, False);
29305 Set_Is_Checked
(N
, False);
29306 Set_Is_Ignored
(N
, True);
29312 Set_Is_Checked
(N
, True);
29313 Set_Is_Ignored
(N
, False);
29315 when Name_Disable
=>
29316 Set_Is_Ignored
(N
, True);
29317 Set_Is_Checked
(N
, False);
29318 Set_Is_Disabled
(N
, True);
29320 -- That should be exhaustive, the null here is a defence
29321 -- against a malformed tree from previous errors.
29330 PP
:= Next_Pragma
(PP
);
29334 -- If there are no specific entries that matched, then we let the
29335 -- setting of assertions govern. Note that this provides the needed
29336 -- compatibility with the RM for the cases of assertion, invariant,
29337 -- precondition, predicate, and postcondition. Note also that
29338 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29340 if Assertions_Enabled
then
29341 Set_Is_Checked
(N
, True);
29342 Set_Is_Ignored
(N
, False);
29344 Set_Is_Checked
(N
, False);
29345 Set_Is_Ignored
(N
, True);
29347 end Check_Applicable_Policy
;
29349 -------------------------------
29350 -- Check_External_Properties --
29351 -------------------------------
29353 procedure Check_External_Properties
29361 -- All properties enabled
29363 if AR
and AW
and ER
and EW
then
29366 -- Async_Readers + Effective_Writes
29367 -- Async_Readers + Async_Writers + Effective_Writes
29369 elsif AR
and EW
and not ER
then
29372 -- Async_Writers + Effective_Reads
29373 -- Async_Readers + Async_Writers + Effective_Reads
29375 elsif AW
and ER
and not EW
then
29378 -- Async_Readers + Async_Writers
29380 elsif AR
and AW
and not ER
and not EW
then
29385 elsif AR
and not AW
and not ER
and not EW
then
29390 elsif AW
and not AR
and not ER
and not EW
then
29395 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29398 end Check_External_Properties
;
29404 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
29408 -- Loop through entries in check policy list
29410 PP
:= Opt
.Check_Policy_List
;
29411 while Present
(PP
) loop
29413 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29414 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29418 or else (Pnm
= Name_Assertion
29419 and then Is_Valid_Assertion_Kind
(Nam
))
29420 or else (Pnm
= Name_Statement_Assertions
29421 and then Nam_In
(Nam
, Name_Assert
,
29422 Name_Assert_And_Cut
,
29424 Name_Loop_Invariant
,
29425 Name_Loop_Variant
))
29427 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
29436 return Name_Ignore
;
29438 when Name_Disable
=>
29439 return Name_Disable
;
29442 raise Program_Error
;
29446 PP
:= Next_Pragma
(PP
);
29451 -- If there are no specific entries that matched, then we let the
29452 -- setting of assertions govern. Note that this provides the needed
29453 -- compatibility with the RM for the cases of assertion, invariant,
29454 -- precondition, predicate, and postcondition.
29456 if Assertions_Enabled
then
29459 return Name_Ignore
;
29463 ---------------------------
29464 -- Check_Missing_Part_Of --
29465 ---------------------------
29467 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
29468 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
29469 -- Determine whether a package denoted by Pack_Id declares at least one
29472 -----------------------
29473 -- Has_Visible_State --
29474 -----------------------
29476 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
29477 Item_Id
: Entity_Id
;
29480 -- Traverse the entity chain of the package trying to find at least
29481 -- one visible abstract state, variable or a package [instantiation]
29482 -- that declares a visible state.
29484 Item_Id
:= First_Entity
(Pack_Id
);
29485 while Present
(Item_Id
)
29486 and then not In_Private_Part
(Item_Id
)
29488 -- Do not consider internally generated items
29490 if not Comes_From_Source
(Item_Id
) then
29493 -- Do not consider generic formals or their corresponding actuals
29494 -- because they are not part of a visible state. Note that both
29495 -- entities are marked as hidden.
29497 elsif Is_Hidden
(Item_Id
) then
29500 -- A visible state has been found. Note that constants are not
29501 -- considered here because it is not possible to determine whether
29502 -- they depend on variable input. This check is left to the SPARK
29505 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
29508 -- Recursively peek into nested packages and instantiations
29510 elsif Ekind
(Item_Id
) = E_Package
29511 and then Has_Visible_State
(Item_Id
)
29516 Next_Entity
(Item_Id
);
29520 end Has_Visible_State
;
29524 Pack_Id
: Entity_Id
;
29525 Placement
: State_Space_Kind
;
29527 -- Start of processing for Check_Missing_Part_Of
29530 -- Do not consider abstract states, variables or package instantiations
29531 -- coming from an instance as those always inherit the Part_Of indicator
29532 -- of the instance itself.
29534 if In_Instance
then
29537 -- Do not consider internally generated entities as these can never
29538 -- have a Part_Of indicator.
29540 elsif not Comes_From_Source
(Item_Id
) then
29543 -- Perform these checks only when SPARK_Mode is enabled as they will
29544 -- interfere with standard Ada rules and produce false positives.
29546 elsif SPARK_Mode
/= On
then
29549 -- Do not consider constants, because the compiler cannot accurately
29550 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29551 -- act as a hidden state of a package.
29553 elsif Ekind
(Item_Id
) = E_Constant
then
29557 -- Find where the abstract state, variable or package instantiation
29558 -- lives with respect to the state space.
29560 Find_Placement_In_State_Space
29561 (Item_Id
=> Item_Id
,
29562 Placement
=> Placement
,
29563 Pack_Id
=> Pack_Id
);
29565 -- Items that appear in a non-package construct (subprogram, block, etc)
29566 -- do not require a Part_Of indicator because they can never act as a
29569 if Placement
= Not_In_Package
then
29572 -- An item declared in the body state space of a package always act as a
29573 -- constituent and does not need explicit Part_Of indicator.
29575 elsif Placement
= Body_State_Space
then
29578 -- In general an item declared in the visible state space of a package
29579 -- does not require a Part_Of indicator. The only exception is when the
29580 -- related package is a nongeneric private child unit, in which case
29581 -- Part_Of must denote a state in the parent unit or in one of its
29584 elsif Placement
= Visible_State_Space
then
29585 if Is_Child_Unit
(Pack_Id
)
29586 and then not Is_Generic_Unit
(Pack_Id
)
29587 and then Is_Private_Descendant
(Pack_Id
)
29589 -- A package instantiation does not need a Part_Of indicator when
29590 -- the related generic template has no visible state.
29592 if Ekind
(Item_Id
) = E_Package
29593 and then Is_Generic_Instance
(Item_Id
)
29594 and then not Has_Visible_State
(Item_Id
)
29598 -- All other cases require Part_Of
29602 ("indicator Part_Of is required in this context "
29603 & "(SPARK RM 7.2.6(3))", Item_Id
);
29604 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29606 ("\& is declared in the visible part of private child "
29607 & "unit %", Item_Id
);
29611 -- When the item appears in the private state space of a package, it
29612 -- must be a part of some state declared by the said package.
29614 else pragma Assert
(Placement
= Private_State_Space
);
29616 -- The related package does not declare a state, the item cannot act
29617 -- as a Part_Of constituent.
29619 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
29622 -- A package instantiation does not need a Part_Of indicator when the
29623 -- related generic template has no visible state.
29625 elsif Ekind
(Item_Id
) = E_Package
29626 and then Is_Generic_Instance
(Item_Id
)
29627 and then not Has_Visible_State
(Item_Id
)
29631 -- All other cases require Part_Of
29635 ("indicator Part_Of is required in this context "
29636 & "(SPARK RM 7.2.6(2))", Item_Id
);
29637 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29639 ("\& is declared in the private part of package %", Item_Id
);
29642 end Check_Missing_Part_Of
;
29644 ---------------------------------------------------
29645 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29646 ---------------------------------------------------
29648 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29650 Spec_Id
: Entity_Id
)
29653 if Warn_On_Redundant_Constructs
29654 and then Has_Pragma_Inline_Always
(Spec_Id
)
29655 and then Assertions_Enabled
29657 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
29659 if From_Aspect_Specification
(Prag
) then
29661 ("aspect % not enforced on inlined subprogram &?r?",
29662 Corresponding_Aspect
(Prag
), Spec_Id
);
29665 ("pragma % not enforced on inlined subprogram &?r?",
29669 end Check_Postcondition_Use_In_Inlined_Subprogram
;
29671 -------------------------------------
29672 -- Check_State_And_Constituent_Use --
29673 -------------------------------------
29675 procedure Check_State_And_Constituent_Use
29676 (States
: Elist_Id
;
29677 Constits
: Elist_Id
;
29680 Constit_Elmt
: Elmt_Id
;
29681 Constit_Id
: Entity_Id
;
29682 State_Id
: Entity_Id
;
29685 -- Nothing to do if there are no states or constituents
29687 if No
(States
) or else No
(Constits
) then
29691 -- Inspect the list of constituents and try to determine whether its
29692 -- encapsulating state is in list States.
29694 Constit_Elmt
:= First_Elmt
(Constits
);
29695 while Present
(Constit_Elmt
) loop
29696 Constit_Id
:= Node
(Constit_Elmt
);
29698 -- Determine whether the constituent is part of an encapsulating
29699 -- state that appears in the same context and if this is the case,
29700 -- emit an error (SPARK RM 7.2.6(7)).
29702 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
29704 if Present
(State_Id
) then
29705 Error_Msg_Name_1
:= Chars
(Constit_Id
);
29707 ("cannot mention state & and its constituent % in the same "
29708 & "context", Context
, State_Id
);
29712 Next_Elmt
(Constit_Elmt
);
29714 end Check_State_And_Constituent_Use
;
29716 ---------------------------------------------
29717 -- Collect_Inherited_Class_Wide_Conditions --
29718 ---------------------------------------------
29720 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
29721 Parent_Subp
: constant Entity_Id
:=
29722 Ultimate_Alias
(Overridden_Operation
(Subp
));
29723 -- The Overridden_Operation may itself be inherited and as such have no
29724 -- explicit contract.
29726 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
29727 In_Spec_Expr
: Boolean;
29728 Installed
: Boolean;
29730 New_Prag
: Node_Id
;
29733 Installed
:= False;
29735 -- Iterate over the contract of the overridden subprogram to find all
29736 -- inherited class-wide pre- and postconditions.
29738 if Present
(Prags
) then
29739 Prag
:= Pre_Post_Conditions
(Prags
);
29741 while Present
(Prag
) loop
29742 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
29743 Name_Precondition
, Name_Postcondition
)
29744 and then Class_Present
(Prag
)
29746 -- The generated pragma must be analyzed in the context of
29747 -- the subprogram, to make its formals visible. In addition,
29748 -- we must inhibit freezing and full analysis because the
29749 -- controlling type of the subprogram is not frozen yet, and
29750 -- may have further primitives.
29752 if not Installed
then
29755 Install_Formals
(Subp
);
29756 In_Spec_Expr
:= In_Spec_Expression
;
29757 In_Spec_Expression
:= True;
29761 Build_Pragma_Check_Equivalent
29762 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
29764 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
29765 Preanalyze
(New_Prag
);
29767 -- Prevent further analysis in subsequent processing of the
29768 -- current list of declarations
29770 Set_Analyzed
(New_Prag
);
29773 Prag
:= Next_Pragma
(Prag
);
29777 In_Spec_Expression
:= In_Spec_Expr
;
29781 end Collect_Inherited_Class_Wide_Conditions
;
29783 ---------------------------------------
29784 -- Collect_Subprogram_Inputs_Outputs --
29785 ---------------------------------------
29787 procedure Collect_Subprogram_Inputs_Outputs
29788 (Subp_Id
: Entity_Id
;
29789 Synthesize
: Boolean := False;
29790 Subp_Inputs
: in out Elist_Id
;
29791 Subp_Outputs
: in out Elist_Id
;
29792 Global_Seen
: out Boolean)
29794 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
29795 -- Collect all relevant items from a dependency clause
29797 procedure Collect_Global_List
29799 Mode
: Name_Id
:= Name_Input
);
29800 -- Collect all relevant items from a global list
29802 -------------------------------
29803 -- Collect_Dependency_Clause --
29804 -------------------------------
29806 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
29807 procedure Collect_Dependency_Item
29809 Is_Input
: Boolean);
29810 -- Add an item to the proper subprogram input or output collection
29812 -----------------------------
29813 -- Collect_Dependency_Item --
29814 -----------------------------
29816 procedure Collect_Dependency_Item
29818 Is_Input
: Boolean)
29823 -- Nothing to collect when the item is null
29825 if Nkind
(Item
) = N_Null
then
29828 -- Ditto for attribute 'Result
29830 elsif Is_Attribute_Result
(Item
) then
29833 -- Multiple items appear as an aggregate
29835 elsif Nkind
(Item
) = N_Aggregate
then
29836 Extra
:= First
(Expressions
(Item
));
29837 while Present
(Extra
) loop
29838 Collect_Dependency_Item
(Extra
, Is_Input
);
29842 -- Otherwise this is a solitary item
29846 Append_New_Elmt
(Item
, Subp_Inputs
);
29848 Append_New_Elmt
(Item
, Subp_Outputs
);
29851 end Collect_Dependency_Item
;
29853 -- Start of processing for Collect_Dependency_Clause
29856 if Nkind
(Clause
) = N_Null
then
29859 -- A dependency clause appears as component association
29861 elsif Nkind
(Clause
) = N_Component_Association
then
29862 Collect_Dependency_Item
29863 (Item
=> Expression
(Clause
),
29866 Collect_Dependency_Item
29867 (Item
=> First
(Choices
(Clause
)),
29868 Is_Input
=> False);
29870 -- To accommodate partial decoration of disabled SPARK features, this
29871 -- routine may be called with illegal input. If this is the case, do
29872 -- not raise Program_Error.
29877 end Collect_Dependency_Clause
;
29879 -------------------------
29880 -- Collect_Global_List --
29881 -------------------------
29883 procedure Collect_Global_List
29885 Mode
: Name_Id
:= Name_Input
)
29887 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
29888 -- Add an item to the proper subprogram input or output collection
29890 -------------------------
29891 -- Collect_Global_Item --
29892 -------------------------
29894 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
29896 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
29897 Append_New_Elmt
(Item
, Subp_Inputs
);
29900 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
29901 Append_New_Elmt
(Item
, Subp_Outputs
);
29903 end Collect_Global_Item
;
29910 -- Start of processing for Collect_Global_List
29913 if Nkind
(List
) = N_Null
then
29916 -- Single global item declaration
29918 elsif Nkind_In
(List
, N_Expanded_Name
,
29920 N_Selected_Component
)
29922 Collect_Global_Item
(List
, Mode
);
29924 -- Simple global list or moded global list declaration
29926 elsif Nkind
(List
) = N_Aggregate
then
29927 if Present
(Expressions
(List
)) then
29928 Item
:= First
(Expressions
(List
));
29929 while Present
(Item
) loop
29930 Collect_Global_Item
(Item
, Mode
);
29935 Assoc
:= First
(Component_Associations
(List
));
29936 while Present
(Assoc
) loop
29937 Collect_Global_List
29938 (List
=> Expression
(Assoc
),
29939 Mode
=> Chars
(First
(Choices
(Assoc
))));
29944 -- To accommodate partial decoration of disabled SPARK features, this
29945 -- routine may be called with illegal input. If this is the case, do
29946 -- not raise Program_Error.
29951 end Collect_Global_List
;
29958 Formal
: Entity_Id
;
29960 Spec_Id
: Entity_Id
:= Empty
;
29961 Subp_Decl
: Node_Id
;
29964 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29967 Global_Seen
:= False;
29969 -- Process all formal parameters of entries, [generic] subprograms, and
29972 if Ekind_In
(Subp_Id
, E_Entry
,
29975 E_Generic_Function
,
29976 E_Generic_Procedure
,
29980 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
29981 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29983 -- Process all formal parameters
29985 Formal
:= First_Entity
(Spec_Id
);
29986 while Present
(Formal
) loop
29987 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
29988 Append_New_Elmt
(Formal
, Subp_Inputs
);
29991 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
29992 Append_New_Elmt
(Formal
, Subp_Outputs
);
29994 -- Out parameters can act as inputs when the related type is
29995 -- tagged, unconstrained array, unconstrained record, or record
29996 -- with unconstrained components.
29998 if Ekind
(Formal
) = E_Out_Parameter
29999 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
30001 Append_New_Elmt
(Formal
, Subp_Inputs
);
30005 Next_Entity
(Formal
);
30008 -- Otherwise the input denotes a task type, a task body, or the
30009 -- anonymous object created for a single task type.
30011 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
30012 or else Is_Single_Task_Object
(Subp_Id
)
30014 Subp_Decl
:= Declaration_Node
(Subp_Id
);
30015 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30018 -- When processing an entry, subprogram or task body, look for pragmas
30019 -- Refined_Depends and Refined_Global as they specify the inputs and
30022 if Is_Entry_Body
(Subp_Id
)
30023 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
30025 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
30026 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
30028 -- Subprogram declaration or stand-alone body case, look for pragmas
30029 -- Depends and Global
30032 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
30033 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
30036 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30037 -- because it provides finer granularity of inputs and outputs.
30039 if Present
(Global
) then
30040 Global_Seen
:= True;
30041 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
30043 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30044 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30045 -- the inputs and outputs from [Refined_]Depends.
30047 elsif Synthesize
and then Present
(Depends
) then
30048 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
30050 -- Multiple dependency clauses appear as an aggregate
30052 if Nkind
(Clauses
) = N_Aggregate
then
30053 Clause
:= First
(Component_Associations
(Clauses
));
30054 while Present
(Clause
) loop
30055 Collect_Dependency_Clause
(Clause
);
30059 -- Otherwise this is a single dependency clause
30062 Collect_Dependency_Clause
(Clauses
);
30066 -- The current instance of a protected type acts as a formal parameter
30067 -- of mode IN for functions and IN OUT for entries and procedures
30068 -- (SPARK RM 6.1.4).
30070 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
30071 Typ
:= Scope
(Spec_Id
);
30073 -- Use the anonymous object when the type is single protected
30075 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30076 Typ
:= Anonymous_Object
(Typ
);
30079 Append_New_Elmt
(Typ
, Subp_Inputs
);
30081 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
30082 Append_New_Elmt
(Typ
, Subp_Outputs
);
30085 -- The current instance of a task type acts as a formal parameter of
30086 -- mode IN OUT (SPARK RM 6.1.4).
30088 elsif Ekind
(Spec_Id
) = E_Task_Type
then
30091 -- Use the anonymous object when the type is single task
30093 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30094 Typ
:= Anonymous_Object
(Typ
);
30097 Append_New_Elmt
(Typ
, Subp_Inputs
);
30098 Append_New_Elmt
(Typ
, Subp_Outputs
);
30100 elsif Is_Single_Task_Object
(Spec_Id
) then
30101 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
30102 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
30104 end Collect_Subprogram_Inputs_Outputs
;
30106 ---------------------------
30107 -- Contract_Freeze_Error --
30108 ---------------------------
30110 procedure Contract_Freeze_Error
30111 (Contract_Id
: Entity_Id
;
30112 Freeze_Id
: Entity_Id
)
30115 Error_Msg_Name_1
:= Chars
(Contract_Id
);
30116 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30119 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
30121 ("\all contractual items must be declared before body #", Contract_Id
);
30122 end Contract_Freeze_Error
;
30124 ---------------------------------
30125 -- Delay_Config_Pragma_Analyze --
30126 ---------------------------------
30128 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
30130 return Nam_In
(Pragma_Name_Unmapped
(N
),
30131 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
30132 end Delay_Config_Pragma_Analyze
;
30134 -----------------------
30135 -- Duplication_Error --
30136 -----------------------
30138 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
30139 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
30140 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
30143 Error_Msg_Sloc
:= Sloc
(Prev
);
30144 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30146 -- Emit a precise message to distinguish between source pragmas and
30147 -- pragmas generated from aspects. The ordering of the two pragmas is
30151 -- Prag -- duplicate
30153 -- No error is emitted when both pragmas come from aspects because this
30154 -- is already detected by the general aspect analysis mechanism.
30156 if Prag_From_Asp
and Prev_From_Asp
then
30158 elsif Prag_From_Asp
then
30159 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
30160 elsif Prev_From_Asp
then
30161 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
30163 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
30165 end Duplication_Error
;
30167 ------------------------------
30168 -- Find_Encapsulating_State --
30169 ------------------------------
30171 function Find_Encapsulating_State
30172 (States
: Elist_Id
;
30173 Constit_Id
: Entity_Id
) return Entity_Id
30175 State_Id
: Entity_Id
;
30178 -- Since a constituent may be part of a larger constituent set, climb
30179 -- the encapsulating state chain looking for a state that appears in
30182 State_Id
:= Encapsulating_State
(Constit_Id
);
30183 while Present
(State_Id
) loop
30184 if Contains
(States
, State_Id
) then
30188 State_Id
:= Encapsulating_State
(State_Id
);
30192 end Find_Encapsulating_State
;
30194 --------------------------
30195 -- Find_Related_Context --
30196 --------------------------
30198 function Find_Related_Context
30200 Do_Checks
: Boolean := False) return Node_Id
30205 Stmt
:= Prev
(Prag
);
30206 while Present
(Stmt
) loop
30208 -- Skip prior pragmas, but check for duplicates
30210 if Nkind
(Stmt
) = N_Pragma
then
30212 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
30219 -- Skip internally generated code
30221 elsif not Comes_From_Source
(Stmt
) then
30223 -- The anonymous object created for a single concurrent type is a
30224 -- suitable context.
30226 if Nkind
(Stmt
) = N_Object_Declaration
30227 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30232 -- Return the current source construct
30242 end Find_Related_Context
;
30244 --------------------------------------
30245 -- Find_Related_Declaration_Or_Body --
30246 --------------------------------------
30248 function Find_Related_Declaration_Or_Body
30250 Do_Checks
: Boolean := False) return Node_Id
30252 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
30254 procedure Expression_Function_Error
;
30255 -- Emit an error concerning pragma Prag that illegaly applies to an
30256 -- expression function.
30258 -------------------------------
30259 -- Expression_Function_Error --
30260 -------------------------------
30262 procedure Expression_Function_Error
is
30264 Error_Msg_Name_1
:= Prag_Nam
;
30266 -- Emit a precise message to distinguish between source pragmas and
30267 -- pragmas generated from aspects.
30269 if From_Aspect_Specification
(Prag
) then
30271 ("aspect % cannot apply to a stand alone expression function",
30275 ("pragma % cannot apply to a stand alone expression function",
30278 end Expression_Function_Error
;
30282 Context
: constant Node_Id
:= Parent
(Prag
);
30285 Look_For_Body
: constant Boolean :=
30286 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
30287 Name_Refined_Global
,
30289 Name_Refined_State
);
30290 -- Refinement pragmas must be associated with a subprogram body [stub]
30292 -- Start of processing for Find_Related_Declaration_Or_Body
30295 Stmt
:= Prev
(Prag
);
30296 while Present
(Stmt
) loop
30298 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30299 -- by splitting a complex pre/postcondition are not considered to
30302 if Nkind
(Stmt
) = N_Pragma
then
30304 and then not Split_PPC
(Stmt
)
30305 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
30312 -- Emit an error when a refinement pragma appears on an expression
30313 -- function without a completion.
30316 and then Look_For_Body
30317 and then Nkind
(Stmt
) = N_Subprogram_Declaration
30318 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
30319 and then not Has_Completion
(Defining_Entity
(Stmt
))
30321 Expression_Function_Error
;
30324 -- The refinement pragma applies to a subprogram body stub
30326 elsif Look_For_Body
30327 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
30331 -- Skip internally generated code
30333 elsif not Comes_From_Source
(Stmt
) then
30335 -- The anonymous object created for a single concurrent type is a
30336 -- suitable context.
30338 if Nkind
(Stmt
) = N_Object_Declaration
30339 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30343 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
30345 -- The subprogram declaration is an internally generated spec
30346 -- for an expression function.
30348 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30351 -- The subprogram declaration is an internally generated spec
30352 -- for a stand-alone subrogram body declared inside a protected
30355 elsif Present
(Corresponding_Body
(Stmt
))
30356 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
30357 and then Is_Protected_Type
(Current_Scope
)
30361 -- The subprogram is actually an instance housed within an
30362 -- anonymous wrapper package.
30364 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30369 -- Return the current construct which is either a subprogram body,
30370 -- a subprogram declaration or is illegal.
30379 -- If we fall through, then the pragma was either the first declaration
30380 -- or it was preceded by other pragmas and no source constructs.
30382 -- The pragma is associated with a library-level subprogram
30384 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
30385 return Unit
(Parent
(Context
));
30387 -- The pragma appears inside the declarations of an entry body
30389 elsif Nkind
(Context
) = N_Entry_Body
then
30392 -- The pragma appears inside the statements of a subprogram body. This
30393 -- placement is the result of subprogram contract expansion.
30395 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
30396 return Parent
(Context
);
30398 -- The pragma appears inside the declarative part of a package body
30400 elsif Nkind
(Context
) = N_Package_Body
then
30403 -- The pragma appears inside the declarative part of a subprogram body
30405 elsif Nkind
(Context
) = N_Subprogram_Body
then
30408 -- The pragma appears inside the declarative part of a task body
30410 elsif Nkind
(Context
) = N_Task_Body
then
30413 -- The pragma appears inside the visible part of a package specification
30415 elsif Nkind
(Context
) = N_Package_Specification
then
30416 return Parent
(Context
);
30418 -- The pragma is a byproduct of aspect expansion, return the related
30419 -- context of the original aspect. This case has a lower priority as
30420 -- the above circuitry pinpoints precisely the related context.
30422 elsif Present
(Corresponding_Aspect
(Prag
)) then
30423 return Parent
(Corresponding_Aspect
(Prag
));
30425 -- No candidate subprogram [body] found
30430 end Find_Related_Declaration_Or_Body
;
30432 ----------------------------------
30433 -- Find_Related_Package_Or_Body --
30434 ----------------------------------
30436 function Find_Related_Package_Or_Body
30438 Do_Checks
: Boolean := False) return Node_Id
30440 Context
: constant Node_Id
:= Parent
(Prag
);
30441 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
30445 Stmt
:= Prev
(Prag
);
30446 while Present
(Stmt
) loop
30448 -- Skip prior pragmas, but check for duplicates
30450 if Nkind
(Stmt
) = N_Pragma
then
30451 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
30457 -- Skip internally generated code
30459 elsif not Comes_From_Source
(Stmt
) then
30460 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
30462 -- The subprogram declaration is an internally generated spec
30463 -- for an expression function.
30465 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30468 -- The subprogram is actually an instance housed within an
30469 -- anonymous wrapper package.
30471 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30476 -- Return the current source construct which is illegal
30485 -- If we fall through, then the pragma was either the first declaration
30486 -- or it was preceded by other pragmas and no source constructs.
30488 -- The pragma is associated with a package. The immediate context in
30489 -- this case is the specification of the package.
30491 if Nkind
(Context
) = N_Package_Specification
then
30492 return Parent
(Context
);
30494 -- The pragma appears in the declarations of a package body
30496 elsif Nkind
(Context
) = N_Package_Body
then
30499 -- The pragma appears in the statements of a package body
30501 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
30502 and then Nkind
(Parent
(Context
)) = N_Package_Body
30504 return Parent
(Context
);
30506 -- The pragma is a byproduct of aspect expansion, return the related
30507 -- context of the original aspect. This case has a lower priority as
30508 -- the above circuitry pinpoints precisely the related context.
30510 elsif Present
(Corresponding_Aspect
(Prag
)) then
30511 return Parent
(Corresponding_Aspect
(Prag
));
30513 -- No candidate package [body] found
30518 end Find_Related_Package_Or_Body
;
30524 function Get_Argument
30526 Context_Id
: Entity_Id
:= Empty
) return Node_Id
30528 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
30531 -- Use the expression of the original aspect when compiling for ASIS or
30532 -- when analyzing the template of a generic unit. In both cases the
30533 -- aspect's tree must be decorated to allow for ASIS queries or to save
30534 -- the global references in the generic context.
30536 if From_Aspect_Specification
(Prag
)
30537 and then (ASIS_Mode
or else (Present
(Context_Id
)
30538 and then Is_Generic_Unit
(Context_Id
)))
30540 return Corresponding_Aspect
(Prag
);
30542 -- Otherwise use the expression of the pragma
30544 elsif Present
(Args
) then
30545 return First
(Args
);
30552 -------------------------
30553 -- Get_Base_Subprogram --
30554 -------------------------
30556 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
30558 -- Follow subprogram renaming chain
30560 if Is_Subprogram
(Def_Id
)
30561 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
30562 N_Subprogram_Renaming_Declaration
30563 and then Present
(Alias
(Def_Id
))
30565 return Alias
(Def_Id
);
30569 end Get_Base_Subprogram
;
30571 -----------------------
30572 -- Get_SPARK_Mode_Type --
30573 -----------------------
30575 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
30577 if N
= Name_On
then
30579 elsif N
= Name_Off
then
30582 -- Any other argument is illegal. Assume that no SPARK mode applies to
30583 -- avoid potential cascaded errors.
30588 end Get_SPARK_Mode_Type
;
30590 ------------------------------------
30591 -- Get_SPARK_Mode_From_Annotation --
30592 ------------------------------------
30594 function Get_SPARK_Mode_From_Annotation
30595 (N
: Node_Id
) return SPARK_Mode_Type
30600 if Nkind
(N
) = N_Aspect_Specification
then
30601 Mode
:= Expression
(N
);
30603 else pragma Assert
(Nkind
(N
) = N_Pragma
);
30604 Mode
:= First
(Pragma_Argument_Associations
(N
));
30606 if Present
(Mode
) then
30607 Mode
:= Get_Pragma_Arg
(Mode
);
30611 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30613 if Present
(Mode
) then
30614 if Nkind
(Mode
) = N_Identifier
then
30615 return Get_SPARK_Mode_Type
(Chars
(Mode
));
30617 -- In case of a malformed aspect or pragma, return the default None
30623 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30628 end Get_SPARK_Mode_From_Annotation
;
30630 ---------------------------
30631 -- Has_Extra_Parentheses --
30632 ---------------------------
30634 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
30638 -- The aggregate should not have an expression list because a clause
30639 -- is always interpreted as a component association. The only way an
30640 -- expression list can sneak in is by adding extra parentheses around
30641 -- the individual clauses:
30643 -- Depends (Output => Input) -- proper form
30644 -- Depends ((Output => Input)) -- extra parentheses
30646 -- Since the extra parentheses are not allowed by the syntax of the
30647 -- pragma, flag them now to avoid emitting misleading errors down the
30650 if Nkind
(Clause
) = N_Aggregate
30651 and then Present
(Expressions
(Clause
))
30653 Expr
:= First
(Expressions
(Clause
));
30654 while Present
(Expr
) loop
30656 -- A dependency clause surrounded by extra parentheses appears
30657 -- as an aggregate of component associations with an optional
30658 -- Paren_Count set.
30660 if Nkind
(Expr
) = N_Aggregate
30661 and then Present
(Component_Associations
(Expr
))
30664 ("dependency clause contains extra parentheses", Expr
);
30666 -- Otherwise the expression is a malformed construct
30669 SPARK_Msg_N
("malformed dependency clause", Expr
);
30679 end Has_Extra_Parentheses
;
30685 procedure Initialize
is
30696 Dummy
:= Dummy
+ 1;
30699 -----------------------------
30700 -- Is_Config_Static_String --
30701 -----------------------------
30703 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30705 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
30706 -- This is an internal recursive function that is just like the outer
30707 -- function except that it adds the string to the name buffer rather
30708 -- than placing the string in the name buffer.
30710 ------------------------------
30711 -- Add_Config_Static_String --
30712 ------------------------------
30714 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30721 if Nkind
(N
) = N_Op_Concat
then
30722 if Add_Config_Static_String
(Left_Opnd
(N
)) then
30723 N
:= Right_Opnd
(N
);
30729 if Nkind
(N
) /= N_String_Literal
then
30730 Error_Msg_N
("string literal expected for pragma argument", N
);
30734 for J
in 1 .. String_Length
(Strval
(N
)) loop
30735 C
:= Get_String_Char
(Strval
(N
), J
);
30737 if not In_Character_Range
(C
) then
30739 ("string literal contains invalid wide character",
30740 Sloc
(N
) + 1 + Source_Ptr
(J
));
30744 Add_Char_To_Name_Buffer
(Get_Character
(C
));
30749 end Add_Config_Static_String
;
30751 -- Start of processing for Is_Config_Static_String
30756 return Add_Config_Static_String
(Arg
);
30757 end Is_Config_Static_String
;
30759 -------------------------------
30760 -- Is_Elaboration_SPARK_Mode --
30761 -------------------------------
30763 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
30766 (Nkind
(N
) = N_Pragma
30767 and then Pragma_Name
(N
) = Name_SPARK_Mode
30768 and then Is_List_Member
(N
));
30770 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30771 -- appears in the statement part of the body.
30774 Present
(Parent
(N
))
30775 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
30776 and then List_Containing
(N
) = Statements
(Parent
(N
))
30777 and then Present
(Parent
(Parent
(N
)))
30778 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
30779 end Is_Elaboration_SPARK_Mode
;
30781 -----------------------
30782 -- Is_Enabled_Pragma --
30783 -----------------------
30785 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
30789 if Present
(Prag
) then
30790 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30792 if Present
(Arg
) then
30793 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
30795 -- The lack of a Boolean argument automatically enables the pragma
30801 -- The pragma is missing, therefore it is not enabled
30806 end Is_Enabled_Pragma
;
30808 -----------------------------------------
30809 -- Is_Non_Significant_Pragma_Reference --
30810 -----------------------------------------
30812 -- This function makes use of the following static table which indicates
30813 -- whether appearance of some name in a given pragma is to be considered
30814 -- as a reference for the purposes of warnings about unreferenced objects.
30816 -- -1 indicates that appearence in any argument is significant
30817 -- 0 indicates that appearance in any argument is not significant
30818 -- +n indicates that appearance as argument n is significant, but all
30819 -- other arguments are not significant
30820 -- 9n arguments from n on are significant, before n insignificant
30822 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
30823 (Pragma_Abort_Defer
=> -1,
30824 Pragma_Abstract_State
=> -1,
30825 Pragma_Acc_Data
=> 0,
30826 Pragma_Acc_Kernels
=> 0,
30827 Pragma_Acc_Loop
=> 0,
30828 Pragma_Acc_Parallel
=> 0,
30829 Pragma_Ada_83
=> -1,
30830 Pragma_Ada_95
=> -1,
30831 Pragma_Ada_05
=> -1,
30832 Pragma_Ada_2005
=> -1,
30833 Pragma_Ada_12
=> -1,
30834 Pragma_Ada_2012
=> -1,
30835 Pragma_Ada_2020
=> -1,
30836 Pragma_All_Calls_Remote
=> -1,
30837 Pragma_Allow_Integer_Address
=> -1,
30838 Pragma_Annotate
=> 93,
30839 Pragma_Assert
=> -1,
30840 Pragma_Assert_And_Cut
=> -1,
30841 Pragma_Assertion_Policy
=> 0,
30842 Pragma_Assume
=> -1,
30843 Pragma_Assume_No_Invalid_Values
=> 0,
30844 Pragma_Async_Readers
=> 0,
30845 Pragma_Async_Writers
=> 0,
30846 Pragma_Asynchronous
=> 0,
30847 Pragma_Atomic
=> 0,
30848 Pragma_Atomic_Components
=> 0,
30849 Pragma_Attach_Handler
=> -1,
30850 Pragma_Attribute_Definition
=> 92,
30851 Pragma_Check
=> -1,
30852 Pragma_Check_Float_Overflow
=> 0,
30853 Pragma_Check_Name
=> 0,
30854 Pragma_Check_Policy
=> 0,
30855 Pragma_CPP_Class
=> 0,
30856 Pragma_CPP_Constructor
=> 0,
30857 Pragma_CPP_Virtual
=> 0,
30858 Pragma_CPP_Vtable
=> 0,
30860 Pragma_C_Pass_By_Copy
=> 0,
30861 Pragma_Comment
=> -1,
30862 Pragma_Common_Object
=> 0,
30863 Pragma_Compile_Time_Error
=> -1,
30864 Pragma_Compile_Time_Warning
=> -1,
30865 Pragma_Compiler_Unit
=> -1,
30866 Pragma_Compiler_Unit_Warning
=> -1,
30867 Pragma_Complete_Representation
=> 0,
30868 Pragma_Complex_Representation
=> 0,
30869 Pragma_Component_Alignment
=> 0,
30870 Pragma_Constant_After_Elaboration
=> 0,
30871 Pragma_Contract_Cases
=> -1,
30872 Pragma_Controlled
=> 0,
30873 Pragma_Convention
=> 0,
30874 Pragma_Convention_Identifier
=> 0,
30875 Pragma_Deadline_Floor
=> -1,
30876 Pragma_Debug
=> -1,
30877 Pragma_Debug_Policy
=> 0,
30878 Pragma_Detect_Blocking
=> 0,
30879 Pragma_Default_Initial_Condition
=> -1,
30880 Pragma_Default_Scalar_Storage_Order
=> 0,
30881 Pragma_Default_Storage_Pool
=> 0,
30882 Pragma_Depends
=> -1,
30883 Pragma_Disable_Atomic_Synchronization
=> 0,
30884 Pragma_Discard_Names
=> 0,
30885 Pragma_Dispatching_Domain
=> -1,
30886 Pragma_Effective_Reads
=> 0,
30887 Pragma_Effective_Writes
=> 0,
30888 Pragma_Elaborate
=> 0,
30889 Pragma_Elaborate_All
=> 0,
30890 Pragma_Elaborate_Body
=> 0,
30891 Pragma_Elaboration_Checks
=> 0,
30892 Pragma_Eliminate
=> 0,
30893 Pragma_Enable_Atomic_Synchronization
=> 0,
30894 Pragma_Export
=> -1,
30895 Pragma_Export_Function
=> -1,
30896 Pragma_Export_Object
=> -1,
30897 Pragma_Export_Procedure
=> -1,
30898 Pragma_Export_Value
=> -1,
30899 Pragma_Export_Valued_Procedure
=> -1,
30900 Pragma_Extend_System
=> -1,
30901 Pragma_Extensions_Allowed
=> 0,
30902 Pragma_Extensions_Visible
=> 0,
30903 Pragma_External
=> -1,
30904 Pragma_Favor_Top_Level
=> 0,
30905 Pragma_External_Name_Casing
=> 0,
30906 Pragma_Fast_Math
=> 0,
30907 Pragma_Finalize_Storage_Only
=> 0,
30909 Pragma_Global
=> -1,
30910 Pragma_Ident
=> -1,
30911 Pragma_Ignore_Pragma
=> 0,
30912 Pragma_Implementation_Defined
=> -1,
30913 Pragma_Implemented
=> -1,
30914 Pragma_Implicit_Packing
=> 0,
30915 Pragma_Import
=> 93,
30916 Pragma_Import_Function
=> 0,
30917 Pragma_Import_Object
=> 0,
30918 Pragma_Import_Procedure
=> 0,
30919 Pragma_Import_Valued_Procedure
=> 0,
30920 Pragma_Independent
=> 0,
30921 Pragma_Independent_Components
=> 0,
30922 Pragma_Initial_Condition
=> -1,
30923 Pragma_Initialize_Scalars
=> 0,
30924 Pragma_Initializes
=> -1,
30925 Pragma_Inline
=> 0,
30926 Pragma_Inline_Always
=> 0,
30927 Pragma_Inline_Generic
=> 0,
30928 Pragma_Inspection_Point
=> -1,
30929 Pragma_Interface
=> 92,
30930 Pragma_Interface_Name
=> 0,
30931 Pragma_Interrupt_Handler
=> -1,
30932 Pragma_Interrupt_Priority
=> -1,
30933 Pragma_Interrupt_State
=> -1,
30934 Pragma_Invariant
=> -1,
30935 Pragma_Keep_Names
=> 0,
30936 Pragma_License
=> 0,
30937 Pragma_Link_With
=> -1,
30938 Pragma_Linker_Alias
=> -1,
30939 Pragma_Linker_Constructor
=> -1,
30940 Pragma_Linker_Destructor
=> -1,
30941 Pragma_Linker_Options
=> -1,
30942 Pragma_Linker_Section
=> -1,
30944 Pragma_Lock_Free
=> 0,
30945 Pragma_Locking_Policy
=> 0,
30946 Pragma_Loop_Invariant
=> -1,
30947 Pragma_Loop_Optimize
=> 0,
30948 Pragma_Loop_Variant
=> -1,
30949 Pragma_Machine_Attribute
=> -1,
30951 Pragma_Main_Storage
=> -1,
30952 Pragma_Max_Entry_Queue_Depth
=> 0,
30953 Pragma_Max_Queue_Length
=> 0,
30954 Pragma_Memory_Size
=> 0,
30955 Pragma_No_Return
=> 0,
30956 Pragma_No_Body
=> 0,
30957 Pragma_No_Component_Reordering
=> -1,
30958 Pragma_No_Elaboration_Code_All
=> 0,
30959 Pragma_No_Heap_Finalization
=> 0,
30960 Pragma_No_Inline
=> 0,
30961 Pragma_No_Run_Time
=> -1,
30962 Pragma_No_Strict_Aliasing
=> -1,
30963 Pragma_No_Tagged_Streams
=> 0,
30964 Pragma_Normalize_Scalars
=> 0,
30965 Pragma_Obsolescent
=> 0,
30966 Pragma_Optimize
=> 0,
30967 Pragma_Optimize_Alignment
=> 0,
30968 Pragma_Overflow_Mode
=> 0,
30969 Pragma_Overriding_Renamings
=> 0,
30970 Pragma_Ordered
=> 0,
30973 Pragma_Part_Of
=> 0,
30974 Pragma_Partition_Elaboration_Policy
=> 0,
30975 Pragma_Passive
=> 0,
30976 Pragma_Persistent_BSS
=> 0,
30977 Pragma_Polling
=> 0,
30978 Pragma_Prefix_Exception_Messages
=> 0,
30980 Pragma_Postcondition
=> -1,
30981 Pragma_Post_Class
=> -1,
30983 Pragma_Precondition
=> -1,
30984 Pragma_Predicate
=> -1,
30985 Pragma_Predicate_Failure
=> -1,
30986 Pragma_Preelaborable_Initialization
=> -1,
30987 Pragma_Preelaborate
=> 0,
30988 Pragma_Pre_Class
=> -1,
30989 Pragma_Priority
=> -1,
30990 Pragma_Priority_Specific_Dispatching
=> 0,
30991 Pragma_Profile
=> 0,
30992 Pragma_Profile_Warnings
=> 0,
30993 Pragma_Propagate_Exceptions
=> 0,
30994 Pragma_Provide_Shift_Operators
=> 0,
30995 Pragma_Psect_Object
=> 0,
30997 Pragma_Pure_Function
=> 0,
30998 Pragma_Queuing_Policy
=> 0,
30999 Pragma_Rational
=> 0,
31000 Pragma_Ravenscar
=> 0,
31001 Pragma_Refined_Depends
=> -1,
31002 Pragma_Refined_Global
=> -1,
31003 Pragma_Refined_Post
=> -1,
31004 Pragma_Refined_State
=> -1,
31005 Pragma_Relative_Deadline
=> 0,
31006 Pragma_Rename_Pragma
=> 0,
31007 Pragma_Remote_Access_Type
=> -1,
31008 Pragma_Remote_Call_Interface
=> -1,
31009 Pragma_Remote_Types
=> -1,
31010 Pragma_Restricted_Run_Time
=> 0,
31011 Pragma_Restriction_Warnings
=> 0,
31012 Pragma_Restrictions
=> 0,
31013 Pragma_Reviewable
=> -1,
31014 Pragma_Secondary_Stack_Size
=> -1,
31015 Pragma_Short_Circuit_And_Or
=> 0,
31016 Pragma_Share_Generic
=> 0,
31017 Pragma_Shared
=> 0,
31018 Pragma_Shared_Passive
=> 0,
31019 Pragma_Short_Descriptors
=> 0,
31020 Pragma_Simple_Storage_Pool_Type
=> 0,
31021 Pragma_Source_File_Name
=> 0,
31022 Pragma_Source_File_Name_Project
=> 0,
31023 Pragma_Source_Reference
=> 0,
31024 Pragma_SPARK_Mode
=> 0,
31025 Pragma_Storage_Size
=> -1,
31026 Pragma_Storage_Unit
=> 0,
31027 Pragma_Static_Elaboration_Desired
=> 0,
31028 Pragma_Stream_Convert
=> 0,
31029 Pragma_Style_Checks
=> 0,
31030 Pragma_Subtitle
=> 0,
31031 Pragma_Suppress
=> 0,
31032 Pragma_Suppress_Exception_Locations
=> 0,
31033 Pragma_Suppress_All
=> 0,
31034 Pragma_Suppress_Debug_Info
=> 0,
31035 Pragma_Suppress_Initialization
=> 0,
31036 Pragma_System_Name
=> 0,
31037 Pragma_Task_Dispatching_Policy
=> 0,
31038 Pragma_Task_Info
=> -1,
31039 Pragma_Task_Name
=> -1,
31040 Pragma_Task_Storage
=> -1,
31041 Pragma_Test_Case
=> -1,
31042 Pragma_Thread_Local_Storage
=> -1,
31043 Pragma_Time_Slice
=> -1,
31045 Pragma_Type_Invariant
=> -1,
31046 Pragma_Type_Invariant_Class
=> -1,
31047 Pragma_Unchecked_Union
=> 0,
31048 Pragma_Unevaluated_Use_Of_Old
=> 0,
31049 Pragma_Unimplemented_Unit
=> 0,
31050 Pragma_Universal_Aliasing
=> 0,
31051 Pragma_Universal_Data
=> 0,
31052 Pragma_Unmodified
=> 0,
31053 Pragma_Unreferenced
=> 0,
31054 Pragma_Unreferenced_Objects
=> 0,
31055 Pragma_Unreserve_All_Interrupts
=> 0,
31056 Pragma_Unsuppress
=> 0,
31057 Pragma_Unused
=> 0,
31058 Pragma_Use_VADS_Size
=> 0,
31059 Pragma_Validity_Checks
=> 0,
31060 Pragma_Volatile
=> 0,
31061 Pragma_Volatile_Components
=> 0,
31062 Pragma_Volatile_Full_Access
=> 0,
31063 Pragma_Volatile_Function
=> 0,
31064 Pragma_Warning_As_Error
=> 0,
31065 Pragma_Warnings
=> 0,
31066 Pragma_Weak_External
=> 0,
31067 Pragma_Wide_Character_Encoding
=> 0,
31068 Unknown_Pragma
=> 0);
31070 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
31076 function Arg_No
return Nat
;
31077 -- Returns an integer showing what argument we are in. A value of
31078 -- zero means we are not in any of the arguments.
31084 function Arg_No
return Nat
is
31089 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
31103 -- Start of processing for Non_Significant_Pragma_Reference
31108 if Nkind
(P
) /= N_Pragma_Argument_Association
then
31112 Id
:= Get_Pragma_Id
(Parent
(P
));
31113 C
:= Sig_Flags
(Id
);
31128 return AN
< (C
- 90);
31134 end Is_Non_Significant_Pragma_Reference
;
31136 ------------------------------
31137 -- Is_Pragma_String_Literal --
31138 ------------------------------
31140 -- This function returns true if the corresponding pragma argument is a
31141 -- static string expression. These are the only cases in which string
31142 -- literals can appear as pragma arguments. We also allow a string literal
31143 -- as the first argument to pragma Assert (although it will of course
31144 -- always generate a type error).
31146 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
31147 Pragn
: constant Node_Id
:= Parent
(Par
);
31148 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
31149 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
31155 N
:= First
(Assoc
);
31162 if Pname
= Name_Assert
then
31165 elsif Pname
= Name_Export
then
31168 elsif Pname
= Name_Ident
then
31171 elsif Pname
= Name_Import
then
31174 elsif Pname
= Name_Interface_Name
then
31177 elsif Pname
= Name_Linker_Alias
then
31180 elsif Pname
= Name_Linker_Section
then
31183 elsif Pname
= Name_Machine_Attribute
then
31186 elsif Pname
= Name_Source_File_Name
then
31189 elsif Pname
= Name_Source_Reference
then
31192 elsif Pname
= Name_Title
then
31195 elsif Pname
= Name_Subtitle
then
31201 end Is_Pragma_String_Literal
;
31203 ---------------------------
31204 -- Is_Private_SPARK_Mode --
31205 ---------------------------
31207 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
31210 (Nkind
(N
) = N_Pragma
31211 and then Pragma_Name
(N
) = Name_SPARK_Mode
31212 and then Is_List_Member
(N
));
31214 -- For pragma SPARK_Mode to be private, it has to appear in the private
31215 -- declarations of a package.
31218 Present
(Parent
(N
))
31219 and then Nkind
(Parent
(N
)) = N_Package_Specification
31220 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
31221 end Is_Private_SPARK_Mode
;
31223 -------------------------------------
31224 -- Is_Unconstrained_Or_Tagged_Item --
31225 -------------------------------------
31227 function Is_Unconstrained_Or_Tagged_Item
31228 (Item
: Entity_Id
) return Boolean
31230 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
31231 -- Determine whether record type Typ has at least one unconstrained
31234 ---------------------------------
31235 -- Has_Unconstrained_Component --
31236 ---------------------------------
31238 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
31242 Comp
:= First_Component
(Typ
);
31243 while Present
(Comp
) loop
31244 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
31248 Next_Component
(Comp
);
31252 end Has_Unconstrained_Component
;
31256 Typ
: constant Entity_Id
:= Etype
(Item
);
31258 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31261 if Is_Tagged_Type
(Typ
) then
31264 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
31267 elsif Is_Record_Type
(Typ
) then
31268 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
31271 return Has_Unconstrained_Component
(Typ
);
31274 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
31280 end Is_Unconstrained_Or_Tagged_Item
;
31282 -----------------------------
31283 -- Is_Valid_Assertion_Kind --
31284 -----------------------------
31286 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
31293 | Name_Assertion_Policy
31294 | Name_Static_Predicate
31295 | Name_Dynamic_Predicate
31300 | Name_Type_Invariant
31301 | Name_uType_Invariant
31305 | Name_Assert_And_Cut
31307 | Name_Contract_Cases
31309 | Name_Default_Initial_Condition
31311 | Name_Initial_Condition
31314 | Name_Loop_Invariant
31315 | Name_Loop_Variant
31316 | Name_Postcondition
31317 | Name_Precondition
31319 | Name_Refined_Post
31320 | Name_Statement_Assertions
31327 end Is_Valid_Assertion_Kind
;
31329 --------------------------------------
31330 -- Process_Compilation_Unit_Pragmas --
31331 --------------------------------------
31333 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
31335 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31336 -- strange because it comes at the end of the unit. Rational has the
31337 -- same name for a pragma, but treats it as a program unit pragma, In
31338 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31339 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31340 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31341 -- the context clause to ensure the correct processing.
31343 if Has_Pragma_Suppress_All
(N
) then
31344 Prepend_To
(Context_Items
(N
),
31345 Make_Pragma
(Sloc
(N
),
31346 Chars
=> Name_Suppress
,
31347 Pragma_Argument_Associations
=> New_List
(
31348 Make_Pragma_Argument_Association
(Sloc
(N
),
31349 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
31352 -- Nothing else to do at the current time
31354 end Process_Compilation_Unit_Pragmas
;
31356 -------------------------------------------
31357 -- Process_Compile_Time_Warning_Or_Error --
31358 -------------------------------------------
31360 procedure Process_Compile_Time_Warning_Or_Error
31364 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
31365 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
31366 Arg2
: constant Node_Id
:= Next
(Arg1
);
31369 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
31371 if Compile_Time_Known_Value
(Arg1x
) then
31372 if Is_True
(Expr_Value
(Arg1x
)) then
31374 -- We have already verified that the second argument is a static
31375 -- string expression. Its string value must be retrieved
31376 -- explicitly if it is a declared constant, otherwise it has
31377 -- been constant-folded previously.
31380 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
31381 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
31382 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
31383 Str
: constant String_Id
:=
31384 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
31385 Str_Len
: constant Nat
:= String_Length
(Str
);
31387 Force
: constant Boolean :=
31388 Prag_Id
= Pragma_Compile_Time_Warning
31389 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
31390 and then (Ekind
(Cent
) /= E_Package
31391 or else not In_Private_Part
(Cent
));
31392 -- Set True if this is the warning case, and we are in the
31393 -- visible part of a package spec, or in a subprogram spec,
31394 -- in which case we want to force the client to see the
31395 -- warning, even though it is not in the main unit.
31403 -- Loop through segments of message separated by line feeds.
31404 -- We output these segments as separate messages with
31405 -- continuation marks for all but the first.
31410 Error_Msg_Strlen
:= 0;
31412 -- Loop to copy characters from argument to error message
31416 exit when Ptr
> Str_Len
;
31417 CC
:= Get_String_Char
(Str
, Ptr
);
31420 -- Ignore wide chars ??? else store character
31422 if In_Character_Range
(CC
) then
31423 C
:= Get_Character
(CC
);
31424 exit when C
= ASCII
.LF
;
31425 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
31426 Error_Msg_String
(Error_Msg_Strlen
) := C
;
31430 -- Here with one line ready to go
31432 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
31434 -- If this is a warning in a spec, then we want clients
31435 -- to see the warning, so mark the message with the
31436 -- special sequence !! to force the warning. In the case
31437 -- of a package spec, we do not force this if we are in
31438 -- the private part of the spec.
31441 if Cont
= False then
31442 Error_Msg
("<<~!!", Eloc
);
31445 Error_Msg
("\<<~!!", Eloc
);
31448 -- Error, rather than warning, or in a body, so we do not
31449 -- need to force visibility for client (error will be
31450 -- output in any case, and this is the situation in which
31451 -- we do not want a client to get a warning, since the
31452 -- warning is in the body or the spec private part).
31455 if Cont
= False then
31456 Error_Msg
("<<~", Eloc
);
31459 Error_Msg
("\<<~", Eloc
);
31463 exit when Ptr
> Str_Len
;
31468 end Process_Compile_Time_Warning_Or_Error
;
31470 ------------------------------------
31471 -- Record_Possible_Body_Reference --
31472 ------------------------------------
31474 procedure Record_Possible_Body_Reference
31475 (State_Id
: Entity_Id
;
31479 Spec_Id
: Entity_Id
;
31482 -- Ensure that we are dealing with a reference to a state
31484 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
31486 -- Climb the tree starting from the reference looking for a package body
31487 -- whose spec declares the referenced state. This criteria automatically
31488 -- excludes references in package specs which are legal. Note that it is
31489 -- not wise to emit an error now as the package body may lack pragma
31490 -- Refined_State or the referenced state may not be mentioned in the
31491 -- refinement. This approach avoids the generation of misleading errors.
31494 while Present
(Context
) loop
31495 if Nkind
(Context
) = N_Package_Body
then
31496 Spec_Id
:= Corresponding_Spec
(Context
);
31498 if Present
(Abstract_States
(Spec_Id
))
31499 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
31501 if No
(Body_References
(State_Id
)) then
31502 Set_Body_References
(State_Id
, New_Elmt_List
);
31505 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
31510 Context
:= Parent
(Context
);
31512 end Record_Possible_Body_Reference
;
31514 ------------------------------------------
31515 -- Relocate_Pragmas_To_Anonymous_Object --
31516 ------------------------------------------
31518 procedure Relocate_Pragmas_To_Anonymous_Object
31519 (Typ_Decl
: Node_Id
;
31520 Obj_Decl
: Node_Id
)
31524 Next_Decl
: Node_Id
;
31527 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
31528 Def
:= Protected_Definition
(Typ_Decl
);
31530 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
31531 Def
:= Task_Definition
(Typ_Decl
);
31534 -- The concurrent definition has a visible declaration list. Inspect it
31535 -- and relocate all canidate pragmas.
31537 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
31538 Decl
:= First
(Visible_Declarations
(Def
));
31539 while Present
(Decl
) loop
31541 -- Preserve the following declaration for iteration purposes due
31542 -- to possible relocation of a pragma.
31544 Next_Decl
:= Next
(Decl
);
31546 if Nkind
(Decl
) = N_Pragma
31547 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
31550 Insert_After
(Obj_Decl
, Decl
);
31552 -- Skip internally generated code
31554 elsif not Comes_From_Source
(Decl
) then
31557 -- No candidate pragmas are available for relocation
31566 end Relocate_Pragmas_To_Anonymous_Object
;
31568 ------------------------------
31569 -- Relocate_Pragmas_To_Body --
31570 ------------------------------
31572 procedure Relocate_Pragmas_To_Body
31573 (Subp_Body
: Node_Id
;
31574 Target_Body
: Node_Id
:= Empty
)
31576 procedure Relocate_Pragma
(Prag
: Node_Id
);
31577 -- Remove a single pragma from its current list and add it to the
31578 -- declarations of the proper body (either Subp_Body or Target_Body).
31580 ---------------------
31581 -- Relocate_Pragma --
31582 ---------------------
31584 procedure Relocate_Pragma
(Prag
: Node_Id
) is
31589 -- When subprogram stubs or expression functions are involves, the
31590 -- destination declaration list belongs to the proper body.
31592 if Present
(Target_Body
) then
31593 Target
:= Target_Body
;
31595 Target
:= Subp_Body
;
31598 Decls
:= Declarations
(Target
);
31602 Set_Declarations
(Target
, Decls
);
31605 -- Unhook the pragma from its current list
31608 Prepend
(Prag
, Decls
);
31609 end Relocate_Pragma
;
31613 Body_Id
: constant Entity_Id
:=
31614 Defining_Unit_Name
(Specification
(Subp_Body
));
31615 Next_Stmt
: Node_Id
;
31618 -- Start of processing for Relocate_Pragmas_To_Body
31621 -- Do not process a body that comes from a separate unit as no construct
31622 -- can possibly follow it.
31624 if not Is_List_Member
(Subp_Body
) then
31627 -- Do not relocate pragmas that follow a stub if the stub does not have
31630 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
31631 and then No
(Target_Body
)
31635 -- Do not process internally generated routine _Postconditions
31637 elsif Ekind
(Body_Id
) = E_Procedure
31638 and then Chars
(Body_Id
) = Name_uPostconditions
31643 -- Look at what is following the body. We are interested in certain kind
31644 -- of pragmas (either from source or byproducts of expansion) that can
31645 -- apply to a body [stub].
31647 Stmt
:= Next
(Subp_Body
);
31648 while Present
(Stmt
) loop
31650 -- Preserve the following statement for iteration purposes due to a
31651 -- possible relocation of a pragma.
31653 Next_Stmt
:= Next
(Stmt
);
31655 -- Move a candidate pragma following the body to the declarations of
31658 if Nkind
(Stmt
) = N_Pragma
31659 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
31662 -- If a source pragma Warnings follows the body, it applies to
31663 -- following statements and does not belong in the body.
31665 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
31666 and then Comes_From_Source
(Stmt
)
31670 Relocate_Pragma
(Stmt
);
31673 -- Skip internally generated code
31675 elsif not Comes_From_Source
(Stmt
) then
31678 -- No candidate pragmas are available for relocation
31686 end Relocate_Pragmas_To_Body
;
31688 -------------------
31689 -- Resolve_State --
31690 -------------------
31692 procedure Resolve_State
(N
: Node_Id
) is
31697 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
31698 Func
:= Entity
(N
);
31700 -- Handle overloading of state names by functions. Traverse the
31701 -- homonym chain looking for an abstract state.
31703 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
31704 pragma Assert
(Is_Overloaded
(N
));
31706 State
:= Homonym
(Func
);
31707 while Present
(State
) loop
31708 if Ekind
(State
) = E_Abstract_State
then
31710 -- Resolve the overloading by setting the proper entity of
31711 -- the reference to that of the state.
31713 Set_Etype
(N
, Standard_Void_Type
);
31714 Set_Entity
(N
, State
);
31715 Set_Is_Overloaded
(N
, False);
31717 Generate_Reference
(State
, N
);
31721 State
:= Homonym
(State
);
31724 -- A function can never act as a state. If the homonym chain does
31725 -- not contain a corresponding state, then something went wrong in
31726 -- the overloading mechanism.
31728 raise Program_Error
;
31733 ----------------------------
31734 -- Rewrite_Assertion_Kind --
31735 ----------------------------
31737 procedure Rewrite_Assertion_Kind
31739 From_Policy
: Boolean := False)
31745 if Nkind
(N
) = N_Attribute_Reference
31746 and then Attribute_Name
(N
) = Name_Class
31747 and then Nkind
(Prefix
(N
)) = N_Identifier
31749 case Chars
(Prefix
(N
)) is
31756 when Name_Type_Invariant
=>
31757 Nam
:= Name_uType_Invariant
;
31759 when Name_Invariant
=>
31760 Nam
:= Name_uInvariant
;
31766 -- Recommend standard use of aspect names Pre/Post
31768 elsif Nkind
(N
) = N_Identifier
31769 and then From_Policy
31770 and then Serious_Errors_Detected
= 0
31771 and then not ASIS_Mode
31773 if Chars
(N
) = Name_Precondition
31774 or else Chars
(N
) = Name_Postcondition
31776 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
31778 ("\use Assertion_Policy and aspect names Pre/Post for "
31779 & "Ada2012 conformance?", N
);
31785 if Nam
/= No_Name
then
31786 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
31788 end Rewrite_Assertion_Kind
;
31796 Dummy
:= Dummy
+ 1;
31799 --------------------------------
31800 -- Set_Encoded_Interface_Name --
31801 --------------------------------
31803 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
31804 Str
: constant String_Id
:= Strval
(S
);
31805 Len
: constant Nat
:= String_Length
(Str
);
31810 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
31813 -- Stores encoded value of character code CC. The encoding we use an
31814 -- underscore followed by four lower case hex digits.
31820 procedure Encode
is
31822 Store_String_Char
(Get_Char_Code
('_'));
31824 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
31826 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
31828 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
31830 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
31833 -- Start of processing for Set_Encoded_Interface_Name
31836 -- If first character is asterisk, this is a link name, and we leave it
31837 -- completely unmodified. We also ignore null strings (the latter case
31838 -- happens only in error cases).
31841 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
31843 Set_Interface_Name
(E
, S
);
31848 CC
:= Get_String_Char
(Str
, J
);
31850 exit when not In_Character_Range
(CC
);
31852 C
:= Get_Character
(CC
);
31854 exit when C
/= '_' and then C
/= '$'
31855 and then C
not in '0' .. '9'
31856 and then C
not in 'a' .. 'z'
31857 and then C
not in 'A' .. 'Z';
31860 Set_Interface_Name
(E
, S
);
31868 -- Here we need to encode. The encoding we use as follows:
31869 -- three underscores + four hex digits (lower case)
31873 for J
in 1 .. String_Length
(Str
) loop
31874 CC
:= Get_String_Char
(Str
, J
);
31876 if not In_Character_Range
(CC
) then
31879 C
:= Get_Character
(CC
);
31881 if C
= '_' or else C
= '$'
31882 or else C
in '0' .. '9'
31883 or else C
in 'a' .. 'z'
31884 or else C
in 'A' .. 'Z'
31886 Store_String_Char
(CC
);
31893 Set_Interface_Name
(E
,
31894 Make_String_Literal
(Sloc
(S
),
31895 Strval
=> End_String
));
31897 end Set_Encoded_Interface_Name
;
31899 ------------------------
31900 -- Set_Elab_Unit_Name --
31901 ------------------------
31903 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
31908 if Nkind
(N
) = N_Identifier
31909 and then Nkind
(With_Item
) = N_Identifier
31911 Set_Entity
(N
, Entity
(With_Item
));
31913 elsif Nkind
(N
) = N_Selected_Component
then
31914 Change_Selected_Component_To_Expanded_Name
(N
);
31915 Set_Entity
(N
, Entity
(With_Item
));
31916 Set_Entity
(Selector_Name
(N
), Entity
(N
));
31918 Pref
:= Prefix
(N
);
31919 Scop
:= Scope
(Entity
(N
));
31920 while Nkind
(Pref
) = N_Selected_Component
loop
31921 Change_Selected_Component_To_Expanded_Name
(Pref
);
31922 Set_Entity
(Selector_Name
(Pref
), Scop
);
31923 Set_Entity
(Pref
, Scop
);
31924 Pref
:= Prefix
(Pref
);
31925 Scop
:= Scope
(Scop
);
31928 Set_Entity
(Pref
, Scop
);
31931 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
31932 end Set_Elab_Unit_Name
;
31934 -------------------
31935 -- Test_Case_Arg --
31936 -------------------
31938 function Test_Case_Arg
31941 From_Aspect
: Boolean := False) return Node_Id
31943 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
31948 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
31953 -- The caller requests the aspect argument
31955 if From_Aspect
then
31956 if Present
(Aspect
)
31957 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
31959 Args
:= Expression
(Aspect
);
31961 -- "Name" and "Mode" may appear without an identifier as a
31962 -- positional association.
31964 if Present
(Expressions
(Args
)) then
31965 Arg
:= First
(Expressions
(Args
));
31967 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31975 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31980 -- Some or all arguments may appear as component associatons
31982 if Present
(Component_Associations
(Args
)) then
31983 Arg
:= First
(Component_Associations
(Args
));
31984 while Present
(Arg
) loop
31985 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
31994 -- Otherwise retrieve the argument directly from the pragma
31997 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
31999 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32003 -- Skip argument "Name"
32007 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32011 -- Skip argument "Mode"
32015 -- Arguments "Requires" and "Ensures" are optional and may not be
32018 while Present
(Arg
) loop
32019 if Chars
(Arg
) = Arg_Nam
then