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 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3689 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3690 -- get the given string argument, and place it in Name_Buffer, adding
3691 -- leading and trailing asterisks if they are not already present. The
3692 -- caller has already checked that Arg is a static string expression.
3694 procedure Ada_2005_Pragma
;
3695 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3696 -- Ada 95 mode, these are implementation defined pragmas, so should be
3697 -- caught by the No_Implementation_Pragmas restriction.
3699 procedure Ada_2012_Pragma
;
3700 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3701 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3702 -- should be caught by the No_Implementation_Pragmas restriction.
3704 procedure Analyze_Depends_Global
3705 (Spec_Id
: out Entity_Id
;
3706 Subp_Decl
: out Node_Id
;
3707 Legal
: out Boolean);
3708 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3709 -- legality of the placement and related context of the pragma. Spec_Id
3710 -- is the entity of the related subprogram. Subp_Decl is the declaration
3711 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3713 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3714 -- Inspect the remainder of the list containing pragma N and look for
3715 -- a pragma that matches Id. If found, analyze the pragma.
3717 procedure Analyze_Pre_Post_Condition
;
3718 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3720 procedure Analyze_Refined_Depends_Global_Post
3721 (Spec_Id
: out Entity_Id
;
3722 Body_Id
: out Entity_Id
;
3723 Legal
: out Boolean);
3724 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3725 -- Refined_Global and Refined_Post. Verify the legality of the placement
3726 -- and related context of the pragma. Spec_Id is the entity of the
3727 -- related subprogram. Body_Id is the entity of the subprogram body.
3728 -- Flag Legal is set when the pragma is legal.
3730 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3731 -- Perform full analysis of pragma Unmodified and the write aspect of
3732 -- pragma Unused. Flag Is_Unused should be set when verifying the
3733 -- semantics of pragma Unused.
3735 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3736 -- Perform full analysis of pragma Unreferenced and the read aspect of
3737 -- pragma Unused. Flag Is_Unused should be set when verifying the
3738 -- semantics of pragma Unused.
3740 procedure Check_Ada_83_Warning
;
3741 -- Issues a warning message for the current pragma if operating in Ada
3742 -- 83 mode (used for language pragmas that are not a standard part of
3743 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3746 procedure Check_Arg_Count
(Required
: Nat
);
3747 -- Check argument count for pragma is equal to given parameter. If not,
3748 -- then issue an error message and raise Pragma_Exit.
3750 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3751 -- Arg which can either be a pragma argument association, in which case
3752 -- the check is applied to the expression of the association or an
3753 -- expression directly.
3755 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3756 -- Check that an argument has the right form for an EXTERNAL_NAME
3757 -- parameter of an extended import/export pragma. The rule is that the
3758 -- name must be an identifier or string literal (in Ada 83 mode) or a
3759 -- static string expression (in Ada 95 mode).
3761 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3762 -- Check the specified argument Arg to make sure that it is an
3763 -- identifier. If not give error and raise Pragma_Exit.
3765 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3766 -- Check the specified argument Arg to make sure that it is an integer
3767 -- literal. If not give error and raise Pragma_Exit.
3769 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3770 -- Check the specified argument Arg to make sure that it has the proper
3771 -- syntactic form for a local name and meets the semantic requirements
3772 -- for a local name. The local name is analyzed as part of the
3773 -- processing for this call. In addition, the local name is required
3774 -- to represent an entity at the library level.
3776 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3777 -- Check the specified argument Arg to make sure that it has the proper
3778 -- syntactic form for a local name and meets the semantic requirements
3779 -- for a local name. The local name is analyzed as part of the
3780 -- processing for this call.
3782 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3783 -- Check the specified argument Arg to make sure that it is a valid
3784 -- locking policy name. If not give error and raise Pragma_Exit.
3786 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3787 -- Check the specified argument Arg to make sure that it is a valid
3788 -- elaboration policy name. If not give error and raise Pragma_Exit.
3790 procedure Check_Arg_Is_One_Of
3793 procedure Check_Arg_Is_One_Of
3795 N1
, N2
, N3
: Name_Id
);
3796 procedure Check_Arg_Is_One_Of
3798 N1
, N2
, N3
, N4
: Name_Id
);
3799 procedure Check_Arg_Is_One_Of
3801 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3802 -- Check the specified argument Arg to make sure that it is an
3803 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3804 -- present). If not then give error and raise Pragma_Exit.
3806 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3807 -- Check the specified argument Arg to make sure that it is a valid
3808 -- queuing policy name. If not give error and raise Pragma_Exit.
3810 procedure Check_Arg_Is_OK_Static_Expression
3812 Typ
: Entity_Id
:= Empty
);
3813 -- Check the specified argument Arg to make sure that it is a static
3814 -- expression of the given type (i.e. it will be analyzed and resolved
3815 -- using this type, which can be any valid argument to Resolve, e.g.
3816 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3817 -- Typ is left Empty, then any static expression is allowed. Includes
3818 -- checking that the argument does not raise Constraint_Error.
3820 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3821 -- Check the specified argument Arg to make sure that it is a valid task
3822 -- dispatching policy name. If not give error and raise Pragma_Exit.
3824 procedure Check_Arg_Order
(Names
: Name_List
);
3825 -- Checks for an instance of two arguments with identifiers for the
3826 -- current pragma which are not in the sequence indicated by Names,
3827 -- and if so, generates a fatal message about bad order of arguments.
3829 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3830 -- Check there are at least N arguments present
3832 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3833 -- Check there are no more than N arguments present
3835 procedure Check_Component
3838 In_Variant_Part
: Boolean := False);
3839 -- Examine an Unchecked_Union component for correct use of per-object
3840 -- constrained subtypes, and for restrictions on finalizable components.
3841 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3842 -- should be set when Comp comes from a record variant.
3844 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3845 -- Check if a rep item of the same name as the current pragma is already
3846 -- chained as a rep pragma to the given entity. If so give a message
3847 -- about the duplicate, and then raise Pragma_Exit so does not return.
3848 -- Note that if E is a type, then this routine avoids flagging a pragma
3849 -- which applies to a parent type from which E is derived.
3851 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3852 -- Nam is an N_String_Literal node containing the external name set by
3853 -- an Import or Export pragma (or extended Import or Export pragma).
3854 -- This procedure checks for possible duplications if this is the export
3855 -- case, and if found, issues an appropriate error message.
3857 procedure Check_Expr_Is_OK_Static_Expression
3859 Typ
: Entity_Id
:= Empty
);
3860 -- Check the specified expression Expr to make sure that it is a static
3861 -- expression of the given type (i.e. it will be analyzed and resolved
3862 -- using this type, which can be any valid argument to Resolve, e.g.
3863 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3864 -- Typ is left Empty, then any static expression is allowed. Includes
3865 -- checking that the expression does not raise Constraint_Error.
3867 procedure Check_First_Subtype
(Arg
: Node_Id
);
3868 -- Checks that Arg, whose expression is an entity name, references a
3871 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3872 -- Checks that the given argument has an identifier, and if so, requires
3873 -- it to match the given identifier name. If there is no identifier, or
3874 -- a non-matching identifier, then an error message is given and
3875 -- Pragma_Exit is raised.
3877 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3878 -- Checks that the given argument has an identifier, and if so, requires
3879 -- it to match one of the given identifier names. If there is no
3880 -- identifier, or a non-matching identifier, then an error message is
3881 -- given and Pragma_Exit is raised.
3883 procedure Check_In_Main_Program
;
3884 -- Common checks for pragmas that appear within a main program
3885 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3887 procedure Check_Interrupt_Or_Attach_Handler
;
3888 -- Common processing for first argument of pragma Interrupt_Handler or
3889 -- pragma Attach_Handler.
3891 procedure Check_Loop_Pragma_Placement
;
3892 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3893 -- appear immediately within a construct restricted to loops, and that
3894 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3896 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3897 -- Check that pragma appears in a declarative part, or in a package
3898 -- specification, i.e. that it does not occur in a statement sequence
3901 procedure Check_No_Identifier
(Arg
: Node_Id
);
3902 -- Checks that the given argument does not have an identifier. If
3903 -- an identifier is present, then an error message is issued, and
3904 -- Pragma_Exit is raised.
3906 procedure Check_No_Identifiers
;
3907 -- Checks that none of the arguments to the pragma has an identifier.
3908 -- If any argument has an identifier, then an error message is issued,
3909 -- and Pragma_Exit is raised.
3911 procedure Check_No_Link_Name
;
3912 -- Checks that no link name is specified
3914 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3915 -- Checks if the given argument has an identifier, and if so, requires
3916 -- it to match the given identifier name. If there is a non-matching
3917 -- identifier, then an error message is given and Pragma_Exit is raised.
3919 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3920 -- Checks if the given argument has an identifier, and if so, requires
3921 -- it to match the given identifier name. If there is a non-matching
3922 -- identifier, then an error message is given and Pragma_Exit is raised.
3923 -- In this version of the procedure, the identifier name is given as
3924 -- a string with lower case letters.
3926 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3927 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3928 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3929 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3930 -- is an OK static boolean expression. Emit an error if this is not the
3933 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3934 -- Constr is a constraint from an N_Subtype_Indication node from a
3935 -- component constraint in an Unchecked_Union type. This routine checks
3936 -- that the constraint is static as required by the restrictions for
3939 procedure Check_Valid_Configuration_Pragma
;
3940 -- Legality checks for placement of a configuration pragma
3942 procedure Check_Valid_Library_Unit_Pragma
;
3943 -- Legality checks for library unit pragmas. A special case arises for
3944 -- pragmas in generic instances that come from copies of the original
3945 -- library unit pragmas in the generic templates. In the case of other
3946 -- than library level instantiations these can appear in contexts which
3947 -- would normally be invalid (they only apply to the original template
3948 -- and to library level instantiations), and they are simply ignored,
3949 -- which is implemented by rewriting them as null statements.
3951 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3952 -- Check an Unchecked_Union variant for lack of nested variants and
3953 -- presence of at least one component. UU_Typ is the related Unchecked_
3956 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3957 -- Subsidiary routine to the processing of pragmas Abstract_State,
3958 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3959 -- Refined_Global and Refined_State. Transform argument Arg into
3960 -- an aggregate if not one already. N_Null is never transformed.
3961 -- Arg may denote an aspect specification or a pragma argument
3964 procedure Error_Pragma
(Msg
: String);
3965 pragma No_Return
(Error_Pragma
);
3966 -- Outputs error message for current pragma. The message contains a %
3967 -- that will be replaced with the pragma name, and the flag is placed
3968 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3969 -- calls Fix_Error (see spec of that procedure for details).
3971 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3972 pragma No_Return
(Error_Pragma_Arg
);
3973 -- Outputs error message for current pragma. The message may contain
3974 -- a % that will be replaced with the pragma name. The parameter Arg
3975 -- may either be a pragma argument association, in which case the flag
3976 -- is placed on the expression of this association, or an expression,
3977 -- in which case the flag is placed directly on the expression. The
3978 -- message is placed using Error_Msg_N, so the message may also contain
3979 -- an & insertion character which will reference the given Arg value.
3980 -- After placing the message, Pragma_Exit is raised. Note: this routine
3981 -- calls Fix_Error (see spec of that procedure for details).
3983 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3984 pragma No_Return
(Error_Pragma_Arg
);
3985 -- Similar to above form of Error_Pragma_Arg except that two messages
3986 -- are provided, the second is a continuation comment starting with \.
3988 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3989 pragma No_Return
(Error_Pragma_Arg_Ident
);
3990 -- Outputs error message for current pragma. The message may contain a %
3991 -- that will be replaced with the pragma name. The parameter Arg must be
3992 -- a pragma argument association with a non-empty identifier (i.e. its
3993 -- Chars field must be set), and the error message is placed on the
3994 -- identifier. The message is placed using Error_Msg_N so the message
3995 -- may also contain an & insertion character which will reference
3996 -- the identifier. After placing the message, Pragma_Exit is raised.
3997 -- Note: this routine calls Fix_Error (see spec of that procedure for
4000 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4001 pragma No_Return
(Error_Pragma_Ref
);
4002 -- Outputs error message for current pragma. The message may contain
4003 -- a % that will be replaced with the pragma name. The parameter Ref
4004 -- must be an entity whose name can be referenced by & and sloc by #.
4005 -- After placing the message, Pragma_Exit is raised. Note: this routine
4006 -- calls Fix_Error (see spec of that procedure for details).
4008 function Find_Lib_Unit_Name
return Entity_Id
;
4009 -- Used for a library unit pragma to find the entity to which the
4010 -- library unit pragma applies, returns the entity found.
4012 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4013 -- If the pragma is a compilation unit pragma, the id must denote the
4014 -- compilation unit in the same compilation, and the pragma must appear
4015 -- in the list of preceding or trailing pragmas. If it is a program
4016 -- unit pragma that is not a compilation unit pragma, then the
4017 -- identifier must be visible.
4019 function Find_Unique_Parameterless_Procedure
4021 Arg
: Node_Id
) return Entity_Id
;
4022 -- Used for a procedure pragma to find the unique parameterless
4023 -- procedure identified by Name, returns it if it exists, otherwise
4024 -- errors out and uses Arg as the pragma argument for the message.
4026 function Fix_Error
(Msg
: String) return String;
4027 -- This is called prior to issuing an error message. Msg is the normal
4028 -- error message issued in the pragma case. This routine checks for the
4029 -- case of a pragma coming from an aspect in the source, and returns a
4030 -- message suitable for the aspect case as follows:
4032 -- Each substring "pragma" is replaced by "aspect"
4034 -- If "argument of" is at the start of the error message text, it is
4035 -- replaced by "entity for".
4037 -- If "argument" is at the start of the error message text, it is
4038 -- replaced by "entity".
4040 -- So for example, "argument of pragma X must be discrete type"
4041 -- returns "entity for aspect X must be a discrete type".
4043 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4044 -- be different from the pragma name). If the current pragma results
4045 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4046 -- original pragma name.
4048 procedure Gather_Associations
4050 Args
: out Args_List
);
4051 -- This procedure is used to gather the arguments for a pragma that
4052 -- permits arbitrary ordering of parameters using the normal rules
4053 -- for named and positional parameters. The Names argument is a list
4054 -- of Name_Id values that corresponds to the allowed pragma argument
4055 -- association identifiers in order. The result returned in Args is
4056 -- a list of corresponding expressions that are the pragma arguments.
4057 -- Note that this is a list of expressions, not of pragma argument
4058 -- associations (Gather_Associations has completely checked all the
4059 -- optional identifiers when it returns). An entry in Args is Empty
4060 -- on return if the corresponding argument is not present.
4062 procedure GNAT_Pragma
;
4063 -- Called for all GNAT defined pragmas to check the relevant restriction
4064 -- (No_Implementation_Pragmas).
4066 function Is_Before_First_Decl
4067 (Pragma_Node
: Node_Id
;
4068 Decls
: List_Id
) return Boolean;
4069 -- Return True if Pragma_Node is before the first declarative item in
4070 -- Decls where Decls is the list of declarative items.
4072 function Is_Configuration_Pragma
return Boolean;
4073 -- Determines if the placement of the current pragma is appropriate
4074 -- for a configuration pragma.
4076 function Is_In_Context_Clause
return Boolean;
4077 -- Returns True if pragma appears within the context clause of a unit,
4078 -- and False for any other placement (does not generate any messages).
4080 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4081 -- Analyzes the argument, and determines if it is a static string
4082 -- expression, returns True if so, False if non-static or not String.
4083 -- A special case is that a string literal returns True in Ada 83 mode
4084 -- (which has no such thing as static string expressions). Note that
4085 -- the call analyzes its argument, so this cannot be used for the case
4086 -- where an identifier might not be declared.
4088 procedure Pragma_Misplaced
;
4089 pragma No_Return
(Pragma_Misplaced
);
4090 -- Issue fatal error message for misplaced pragma
4092 procedure Process_Atomic_Independent_Shared_Volatile
;
4093 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4094 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4095 -- and treated as being identical in effect to pragma Atomic.
4097 procedure Process_Compile_Time_Warning_Or_Error
;
4098 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4100 procedure Process_Convention
4101 (C
: out Convention_Id
;
4102 Ent
: out Entity_Id
);
4103 -- Common processing for Convention, Interface, Import and Export.
4104 -- Checks first two arguments of pragma, and sets the appropriate
4105 -- convention value in the specified entity or entities. On return
4106 -- C is the convention, Ent is the referenced entity.
4108 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4109 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4110 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4112 procedure Process_Extended_Import_Export_Object_Pragma
4113 (Arg_Internal
: Node_Id
;
4114 Arg_External
: Node_Id
;
4115 Arg_Size
: Node_Id
);
4116 -- Common processing for the pragmas Import/Export_Object. The three
4117 -- arguments correspond to the three named parameters of the pragmas. An
4118 -- argument is empty if the corresponding parameter is not present in
4121 procedure Process_Extended_Import_Export_Internal_Arg
4122 (Arg_Internal
: Node_Id
:= Empty
);
4123 -- Common processing for all extended Import and Export pragmas. The
4124 -- argument is the pragma parameter for the Internal argument. If
4125 -- Arg_Internal is empty or inappropriate, an error message is posted.
4126 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4127 -- set to identify the referenced entity.
4129 procedure Process_Extended_Import_Export_Subprogram_Pragma
4130 (Arg_Internal
: Node_Id
;
4131 Arg_External
: Node_Id
;
4132 Arg_Parameter_Types
: Node_Id
;
4133 Arg_Result_Type
: Node_Id
:= Empty
;
4134 Arg_Mechanism
: Node_Id
;
4135 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4136 -- Common processing for all extended Import and Export pragmas applying
4137 -- to subprograms. The caller omits any arguments that do not apply to
4138 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4139 -- only in the Import_Function and Export_Function cases). The argument
4140 -- names correspond to the allowed pragma association identifiers.
4142 procedure Process_Generic_List
;
4143 -- Common processing for Share_Generic and Inline_Generic
4145 procedure Process_Import_Or_Interface
;
4146 -- Common processing for Import or Interface
4148 procedure Process_Import_Predefined_Type
;
4149 -- Processing for completing a type with pragma Import. This is used
4150 -- to declare types that match predefined C types, especially for cases
4151 -- without corresponding Ada predefined type.
4153 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4154 -- Inline status of a subprogram, indicated as follows:
4155 -- Suppressed: inlining is suppressed for the subprogram
4156 -- Disabled: no inlining is requested for the subprogram
4157 -- Enabled: inlining is requested/required for the subprogram
4159 procedure Process_Inline
(Status
: Inline_Status
);
4160 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4161 -- indicates the inline status specified by the pragma.
4163 procedure Process_Interface_Name
4164 (Subprogram_Def
: Entity_Id
;
4168 -- Given the last two arguments of pragma Import, pragma Export, or
4169 -- pragma Interface_Name, performs validity checks and sets the
4170 -- Interface_Name field of the given subprogram entity to the
4171 -- appropriate external or link name, depending on the arguments given.
4172 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4173 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4174 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4175 -- nor Link_Arg is present, the interface name is set to the default
4176 -- from the subprogram name. In addition, the pragma itself is passed
4177 -- to analyze any expressions in the case the pragma came from an aspect
4180 procedure Process_Interrupt_Or_Attach_Handler
;
4181 -- Common processing for Interrupt and Attach_Handler pragmas
4183 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4184 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4185 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4186 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4187 -- is not set in the Restrictions case.
4189 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4190 -- Common processing for Suppress and Unsuppress. The boolean parameter
4191 -- Suppress_Case is True for the Suppress case, and False for the
4194 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4195 -- Subsidiary to the analysis of pragmas Independent[_Components].
4196 -- Record such a pragma N applied to entity E for future checks.
4198 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4199 -- This procedure sets the Is_Exported flag for the given entity,
4200 -- checking that the entity was not previously imported. Arg is
4201 -- the argument that specified the entity. A check is also made
4202 -- for exporting inappropriate entities.
4204 procedure Set_Extended_Import_Export_External_Name
4205 (Internal_Ent
: Entity_Id
;
4206 Arg_External
: Node_Id
);
4207 -- Common processing for all extended import export pragmas. The first
4208 -- argument, Internal_Ent, is the internal entity, which has already
4209 -- been checked for validity by the caller. Arg_External is from the
4210 -- Import or Export pragma, and may be null if no External parameter
4211 -- was present. If Arg_External is present and is a non-null string
4212 -- (a null string is treated as the default), then the Interface_Name
4213 -- field of Internal_Ent is set appropriately.
4215 procedure Set_Imported
(E
: Entity_Id
);
4216 -- This procedure sets the Is_Imported flag for the given entity,
4217 -- checking that it is not previously exported or imported.
4219 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4220 -- Mech is a parameter passing mechanism (see Import_Function syntax
4221 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4222 -- has the right form, and if not issues an error message. If the
4223 -- argument has the right form then the Mechanism field of Ent is
4224 -- set appropriately.
4226 procedure Set_Rational_Profile
;
4227 -- Activate the set of configuration pragmas and permissions that make
4228 -- up the Rational profile.
4230 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4231 -- Activate the set of configuration pragmas and restrictions that make
4232 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4233 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4234 -- which is used for error messages on any constructs violating the
4237 ----------------------------------
4238 -- Acquire_Warning_Match_String --
4239 ----------------------------------
4241 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4243 String_To_Name_Buffer
4244 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4246 -- Add asterisk at start if not already there
4248 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4249 Name_Buffer
(2 .. Name_Len
+ 1) :=
4250 Name_Buffer
(1 .. Name_Len
);
4251 Name_Buffer
(1) := '*';
4252 Name_Len
:= Name_Len
+ 1;
4255 -- Add asterisk at end if not already there
4257 if Name_Buffer
(Name_Len
) /= '*' then
4258 Name_Len
:= Name_Len
+ 1;
4259 Name_Buffer
(Name_Len
) := '*';
4261 end Acquire_Warning_Match_String
;
4263 ---------------------
4264 -- Ada_2005_Pragma --
4265 ---------------------
4267 procedure Ada_2005_Pragma
is
4269 if Ada_Version
<= Ada_95
then
4270 Check_Restriction
(No_Implementation_Pragmas
, N
);
4272 end Ada_2005_Pragma
;
4274 ---------------------
4275 -- Ada_2012_Pragma --
4276 ---------------------
4278 procedure Ada_2012_Pragma
is
4280 if Ada_Version
<= Ada_2005
then
4281 Check_Restriction
(No_Implementation_Pragmas
, N
);
4283 end Ada_2012_Pragma
;
4285 ----------------------------
4286 -- Analyze_Depends_Global --
4287 ----------------------------
4289 procedure Analyze_Depends_Global
4290 (Spec_Id
: out Entity_Id
;
4291 Subp_Decl
: out Node_Id
;
4292 Legal
: out Boolean)
4295 -- Assume that the pragma is illegal
4302 Check_Arg_Count
(1);
4304 -- Ensure the proper placement of the pragma. Depends/Global must be
4305 -- associated with a subprogram declaration or a body that acts as a
4308 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4312 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4315 -- Generic subprogram
4317 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4320 -- Object declaration of a single concurrent type
4322 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4323 and then Is_Single_Concurrent_Object
4324 (Unique_Defining_Entity
(Subp_Decl
))
4330 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4333 -- Subprogram body acts as spec
4335 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4336 and then No
(Corresponding_Spec
(Subp_Decl
))
4340 -- Subprogram body stub acts as spec
4342 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4343 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4347 -- Subprogram declaration
4349 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4354 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4362 -- If we get here, then the pragma is legal
4365 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4367 -- When the related context is an entry, the entry must belong to a
4368 -- protected unit (SPARK RM 6.1.4(6)).
4370 if Is_Entry_Declaration
(Spec_Id
)
4371 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4376 -- When the related context is an anonymous object created for a
4377 -- simple concurrent type, the type must be a task
4378 -- (SPARK RM 6.1.4(6)).
4380 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4381 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4387 -- A pragma that applies to a Ghost entity becomes Ghost for the
4388 -- purposes of legality checks and removal of ignored Ghost code.
4390 Mark_Ghost_Pragma
(N
, Spec_Id
);
4391 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4392 end Analyze_Depends_Global
;
4394 ------------------------
4395 -- Analyze_If_Present --
4396 ------------------------
4398 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4402 pragma Assert
(Is_List_Member
(N
));
4404 -- Inspect the declarations or statements following pragma N looking
4405 -- for another pragma whose Id matches the caller's request. If it is
4406 -- available, analyze it.
4409 while Present
(Stmt
) loop
4410 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4411 Analyze_Pragma
(Stmt
);
4414 -- The first source declaration or statement immediately following
4415 -- N ends the region where a pragma may appear.
4417 elsif Comes_From_Source
(Stmt
) then
4423 end Analyze_If_Present
;
4425 --------------------------------
4426 -- Analyze_Pre_Post_Condition --
4427 --------------------------------
4429 procedure Analyze_Pre_Post_Condition
is
4430 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4431 Subp_Decl
: Node_Id
;
4432 Subp_Id
: Entity_Id
;
4434 Duplicates_OK
: Boolean := False;
4435 -- Flag set when a pre/postcondition allows multiple pragmas of the
4438 In_Body_OK
: Boolean := False;
4439 -- Flag set when a pre/postcondition is allowed to appear on a body
4440 -- even though the subprogram may have a spec.
4442 Is_Pre_Post
: Boolean := False;
4443 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4446 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4447 -- Implement rules in AI12-0131: an overriding operation can have
4448 -- a class-wide precondition only if one of its ancestors has an
4449 -- explicit class-wide precondition.
4451 -----------------------------
4452 -- Inherits_Class_Wide_Pre --
4453 -----------------------------
4455 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4456 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4459 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4462 -- Check ancestors on the overriding operation to examine the
4463 -- preconditions that may apply to them.
4465 while Present
(Prev
) loop
4466 Cont
:= Contract
(Prev
);
4467 if Present
(Cont
) then
4468 Prag
:= Pre_Post_Conditions
(Cont
);
4469 while Present
(Prag
) loop
4470 if Pragma_Name
(Prag
) = Name_Precondition
4471 and then Class_Present
(Prag
)
4476 Prag
:= Next_Pragma
(Prag
);
4480 -- For a type derived from a generic formal type, the operation
4481 -- inheriting the condition is a renaming, not an overriding of
4482 -- the operation of the formal. Ditto for an inherited
4483 -- operation which has no explicit contracts.
4485 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4486 or else not Comes_From_Source
(Prev
)
4488 Prev
:= Alias
(Prev
);
4490 Prev
:= Overridden_Operation
(Prev
);
4494 -- If the controlling type of the subprogram has progenitors, an
4495 -- interface operation implemented by the current operation may
4496 -- have a class-wide precondition.
4498 if Has_Interfaces
(Typ
) then
4503 Prim_Elmt
: Elmt_Id
;
4504 Prim_List
: Elist_Id
;
4507 Collect_Interfaces
(Typ
, Ints
);
4508 Elmt
:= First_Elmt
(Ints
);
4510 -- Iterate over the primitive operations of each interface
4512 while Present
(Elmt
) loop
4513 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4514 Prim_Elmt
:= First_Elmt
(Prim_List
);
4515 while Present
(Prim_Elmt
) loop
4516 Prim
:= Node
(Prim_Elmt
);
4517 if Chars
(Prim
) = Chars
(E
)
4518 and then Present
(Contract
(Prim
))
4519 and then Class_Present
4520 (Pre_Post_Conditions
(Contract
(Prim
)))
4525 Next_Elmt
(Prim_Elmt
);
4534 end Inherits_Class_Wide_Pre
;
4536 -- Start of processing for Analyze_Pre_Post_Condition
4539 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4540 -- offer uniformity among the various kinds of pre/postconditions by
4541 -- rewriting the pragma identifier. This allows the retrieval of the
4542 -- original pragma name by routine Original_Aspect_Pragma_Name.
4544 if Comes_From_Source
(N
) then
4545 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4546 Is_Pre_Post
:= True;
4547 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4548 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4550 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4551 Is_Pre_Post
:= True;
4552 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4553 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4557 -- Determine the semantics with respect to duplicates and placement
4558 -- in a body. Pragmas Precondition and Postcondition were introduced
4559 -- before aspects and are not subject to the same aspect-like rules.
4561 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4562 Duplicates_OK
:= True;
4568 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4569 -- argument without an identifier.
4572 Check_Arg_Count
(1);
4573 Check_No_Identifiers
;
4575 -- Pragmas Precondition and Postcondition have complex argument
4579 Check_At_Least_N_Arguments
(1);
4580 Check_At_Most_N_Arguments
(2);
4581 Check_Optional_Identifier
(Arg1
, Name_Check
);
4583 if Present
(Arg2
) then
4584 Check_Optional_Identifier
(Arg2
, Name_Message
);
4585 Preanalyze_Spec_Expression
4586 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4590 -- For a pragma PPC in the extended main source unit, record enabled
4592 -- ??? nothing checks that the pragma is in the main source unit
4594 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4595 Set_SCO_Pragma_Enabled
(Loc
);
4598 -- Ensure the proper placement of the pragma
4601 Find_Related_Declaration_Or_Body
4602 (N
, Do_Checks
=> not Duplicates_OK
);
4604 -- When a pre/postcondition pragma applies to an abstract subprogram,
4605 -- its original form must be an aspect with 'Class.
4607 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4608 if not From_Aspect_Specification
(N
) then
4610 ("pragma % cannot be applied to abstract subprogram");
4612 elsif not Class_Present
(N
) then
4614 ("aspect % requires ''Class for abstract subprogram");
4617 -- Entry declaration
4619 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4622 -- Generic subprogram declaration
4624 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4629 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4630 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4634 -- Subprogram body stub
4636 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4637 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4641 -- Subprogram declaration
4643 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4645 -- AI05-0230: When a pre/postcondition pragma applies to a null
4646 -- procedure, its original form must be an aspect with 'Class.
4648 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4649 and then Null_Present
(Specification
(Subp_Decl
))
4650 and then From_Aspect_Specification
(N
)
4651 and then not Class_Present
(N
)
4653 Error_Pragma
("aspect % requires ''Class for null procedure");
4656 -- Implement the legality checks mandated by AI12-0131:
4657 -- Pre'Class shall not be specified for an overriding primitive
4658 -- subprogram of a tagged type T unless the Pre'Class aspect is
4659 -- specified for the corresponding primitive subprogram of some
4663 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4666 if Class_Present
(N
)
4667 and then Pragma_Name
(N
) = Name_Precondition
4668 and then Present
(Overridden_Operation
(E
))
4669 and then not Inherits_Class_Wide_Pre
(E
)
4672 ("illegal class-wide precondition on overriding operation",
4673 Corresponding_Aspect
(N
));
4677 -- A renaming declaration may inherit a generated pragma, its
4678 -- placement comes from expansion, not from source.
4680 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4681 and then not Comes_From_Source
(N
)
4685 -- Otherwise the placement is illegal
4692 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4694 -- A pragma that applies to a Ghost entity becomes Ghost for the
4695 -- purposes of legality checks and removal of ignored Ghost code.
4697 Mark_Ghost_Pragma
(N
, Subp_Id
);
4699 -- Chain the pragma on the contract for further processing by
4700 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4702 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4704 -- Fully analyze the pragma when it appears inside an entry or
4705 -- subprogram body because it cannot benefit from forward references.
4707 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4709 N_Subprogram_Body_Stub
)
4711 -- The legality checks of pragmas Precondition and Postcondition
4712 -- are affected by the SPARK mode in effect and the volatility of
4713 -- the context. Analyze all pragmas in a specific order.
4715 Analyze_If_Present
(Pragma_SPARK_Mode
);
4716 Analyze_If_Present
(Pragma_Volatile_Function
);
4717 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4719 end Analyze_Pre_Post_Condition
;
4721 -----------------------------------------
4722 -- Analyze_Refined_Depends_Global_Post --
4723 -----------------------------------------
4725 procedure Analyze_Refined_Depends_Global_Post
4726 (Spec_Id
: out Entity_Id
;
4727 Body_Id
: out Entity_Id
;
4728 Legal
: out Boolean)
4730 Body_Decl
: Node_Id
;
4731 Spec_Decl
: Node_Id
;
4734 -- Assume that the pragma is illegal
4741 Check_Arg_Count
(1);
4742 Check_No_Identifiers
;
4744 -- Verify the placement of the pragma and check for duplicates. The
4745 -- pragma must apply to a subprogram body [stub].
4747 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4749 if not Nkind_In
(Body_Decl
, N_Entry_Body
,
4751 N_Subprogram_Body_Stub
,
4759 Body_Id
:= Defining_Entity
(Body_Decl
);
4760 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4762 -- The pragma must apply to the second declaration of a subprogram.
4763 -- In other words, the body [stub] cannot acts as a spec.
4765 if No
(Spec_Id
) then
4766 Error_Pragma
("pragma % cannot apply to a stand alone body");
4769 -- Catch the case where the subprogram body is a subunit and acts as
4770 -- the third declaration of the subprogram.
4772 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4773 Error_Pragma
("pragma % cannot apply to a subunit");
4777 -- A refined pragma can only apply to the body [stub] of a subprogram
4778 -- declared in the visible part of a package. Retrieve the context of
4779 -- the subprogram declaration.
4781 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4783 -- When dealing with protected entries or protected subprograms, use
4784 -- the enclosing protected type as the proper context.
4786 if Ekind_In
(Spec_Id
, E_Entry
,
4790 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4792 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4795 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4797 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4798 & "subprogram declared in a package specification"));
4802 -- If we get here, then the pragma is legal
4806 -- A pragma that applies to a Ghost entity becomes Ghost for the
4807 -- purposes of legality checks and removal of ignored Ghost code.
4809 Mark_Ghost_Pragma
(N
, Spec_Id
);
4811 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4812 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4814 end Analyze_Refined_Depends_Global_Post
;
4816 ----------------------------------
4817 -- Analyze_Unmodified_Or_Unused --
4818 ----------------------------------
4820 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4825 Ghost_Error_Posted
: Boolean := False;
4826 -- Flag set when an error concerning the illegal mix of Ghost and
4827 -- non-Ghost variables is emitted.
4829 Ghost_Id
: Entity_Id
:= Empty
;
4830 -- The entity of the first Ghost variable encountered while
4831 -- processing the arguments of the pragma.
4835 Check_At_Least_N_Arguments
(1);
4837 -- Loop through arguments
4840 while Present
(Arg
) loop
4841 Check_No_Identifier
(Arg
);
4843 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4844 -- in fact generate reference, so that the entity will have a
4845 -- reference, which will inhibit any warnings about it not
4846 -- being referenced, and also properly show up in the ali file
4847 -- as a reference. But this reference is recorded before the
4848 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4849 -- generated for this reference.
4851 Check_Arg_Is_Local_Name
(Arg
);
4852 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4854 if Is_Entity_Name
(Arg_Expr
) then
4855 Arg_Id
:= Entity
(Arg_Expr
);
4857 -- Skip processing the argument if already flagged
4859 if Is_Assignable
(Arg_Id
)
4860 and then not Has_Pragma_Unmodified
(Arg_Id
)
4861 and then not Has_Pragma_Unused
(Arg_Id
)
4863 Set_Has_Pragma_Unmodified
(Arg_Id
);
4866 Set_Has_Pragma_Unused
(Arg_Id
);
4869 -- A pragma that applies to a Ghost entity becomes Ghost for
4870 -- the purposes of legality checks and removal of ignored
4873 Mark_Ghost_Pragma
(N
, Arg_Id
);
4875 -- Capture the entity of the first Ghost variable being
4876 -- processed for error detection purposes.
4878 if Is_Ghost_Entity
(Arg_Id
) then
4879 if No
(Ghost_Id
) then
4883 -- Otherwise the variable is non-Ghost. It is illegal to mix
4884 -- references to Ghost and non-Ghost entities
4887 elsif Present
(Ghost_Id
)
4888 and then not Ghost_Error_Posted
4890 Ghost_Error_Posted
:= True;
4892 Error_Msg_Name_1
:= Pname
;
4894 ("pragma % cannot mention ghost and non-ghost "
4897 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4898 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4900 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4901 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4904 -- Warn if already flagged as Unused or Unmodified
4906 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4907 if Has_Pragma_Unused
(Arg_Id
) then
4909 ("??pragma Unused already given for &!", Arg_Expr
,
4913 ("??pragma Unmodified already given for &!", Arg_Expr
,
4917 -- Otherwise the pragma referenced an illegal entity
4921 ("pragma% can only be applied to a variable", Arg_Expr
);
4927 end Analyze_Unmodified_Or_Unused
;
4929 ------------------------------------
4930 -- Analyze_Unreferenced_Or_Unused --
4931 ------------------------------------
4933 procedure Analyze_Unreferenced_Or_Unused
4934 (Is_Unused
: Boolean := False)
4941 Ghost_Error_Posted
: Boolean := False;
4942 -- Flag set when an error concerning the illegal mix of Ghost and
4943 -- non-Ghost names is emitted.
4945 Ghost_Id
: Entity_Id
:= Empty
;
4946 -- The entity of the first Ghost name encountered while processing
4947 -- the arguments of the pragma.
4951 Check_At_Least_N_Arguments
(1);
4953 -- Check case of appearing within context clause
4955 if not Is_Unused
and then Is_In_Context_Clause
then
4957 -- The arguments must all be units mentioned in a with clause in
4958 -- the same context clause. Note that Par.Prag already checked
4959 -- that the arguments are either identifiers or selected
4963 while Present
(Arg
) loop
4964 Citem
:= First
(List_Containing
(N
));
4965 while Citem
/= N
loop
4966 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4968 if Nkind
(Citem
) = N_With_Clause
4969 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4971 Set_Has_Pragma_Unreferenced
4974 (Library_Unit
(Citem
))));
4975 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4984 ("argument of pragma% is not withed unit", Arg
);
4990 -- Case of not in list of context items
4994 while Present
(Arg
) loop
4995 Check_No_Identifier
(Arg
);
4997 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4998 -- in fact generate reference, so that the entity will have a
4999 -- reference, which will inhibit any warnings about it not
5000 -- being referenced, and also properly show up in the ali file
5001 -- as a reference. But this reference is recorded before the
5002 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5003 -- generated for this reference.
5005 Check_Arg_Is_Local_Name
(Arg
);
5006 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5008 if Is_Entity_Name
(Arg_Expr
) then
5009 Arg_Id
:= Entity
(Arg_Expr
);
5011 -- Warn if already flagged as Unused or Unreferenced and
5012 -- skip processing the argument.
5014 if Has_Pragma_Unreferenced
(Arg_Id
) then
5015 if Has_Pragma_Unused
(Arg_Id
) then
5017 ("??pragma Unused already given for &!", Arg_Expr
,
5021 ("??pragma Unreferenced already given for &!",
5025 -- Apply Unreferenced to the entity
5028 -- If the entity is overloaded, the pragma applies to the
5029 -- most recent overloading, as documented. In this case,
5030 -- name resolution does not generate a reference, so it
5031 -- must be done here explicitly.
5033 if Is_Overloaded
(Arg_Expr
) then
5034 Generate_Reference
(Arg_Id
, N
);
5037 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5040 Set_Has_Pragma_Unused
(Arg_Id
);
5043 -- A pragma that applies to a Ghost entity becomes Ghost
5044 -- for the purposes of legality checks and removal of
5045 -- ignored Ghost code.
5047 Mark_Ghost_Pragma
(N
, Arg_Id
);
5049 -- Capture the entity of the first Ghost name being
5050 -- processed for error detection purposes.
5052 if Is_Ghost_Entity
(Arg_Id
) then
5053 if No
(Ghost_Id
) then
5057 -- Otherwise the name is non-Ghost. It is illegal to mix
5058 -- references to Ghost and non-Ghost entities
5061 elsif Present
(Ghost_Id
)
5062 and then not Ghost_Error_Posted
5064 Ghost_Error_Posted
:= True;
5066 Error_Msg_Name_1
:= Pname
;
5068 ("pragma % cannot mention ghost and non-ghost "
5071 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5073 ("\& # declared as ghost", N
, Ghost_Id
);
5075 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5077 ("\& # declared as non-ghost", N
, Arg_Id
);
5085 end Analyze_Unreferenced_Or_Unused
;
5087 --------------------------
5088 -- Check_Ada_83_Warning --
5089 --------------------------
5091 procedure Check_Ada_83_Warning
is
5093 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5094 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5096 end Check_Ada_83_Warning
;
5098 ---------------------
5099 -- Check_Arg_Count --
5100 ---------------------
5102 procedure Check_Arg_Count
(Required
: Nat
) is
5104 if Arg_Count
/= Required
then
5105 Error_Pragma
("wrong number of arguments for pragma%");
5107 end Check_Arg_Count
;
5109 --------------------------------
5110 -- Check_Arg_Is_External_Name --
5111 --------------------------------
5113 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5114 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5117 if Nkind
(Argx
) = N_Identifier
then
5121 Analyze_And_Resolve
(Argx
, Standard_String
);
5123 if Is_OK_Static_Expression
(Argx
) then
5126 elsif Etype
(Argx
) = Any_Type
then
5129 -- An interesting special case, if we have a string literal and
5130 -- we are in Ada 83 mode, then we allow it even though it will
5131 -- not be flagged as static. This allows expected Ada 83 mode
5132 -- use of external names which are string literals, even though
5133 -- technically these are not static in Ada 83.
5135 elsif Ada_Version
= Ada_83
5136 and then Nkind
(Argx
) = N_String_Literal
5140 -- Here we have a real error (non-static expression)
5143 Error_Msg_Name_1
:= Pname
;
5144 Flag_Non_Static_Expr
5145 (Fix_Error
("argument for pragma% must be a identifier or "
5146 & "static string expression!"), Argx
);
5151 end Check_Arg_Is_External_Name
;
5153 -----------------------------
5154 -- Check_Arg_Is_Identifier --
5155 -----------------------------
5157 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5158 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5160 if Nkind
(Argx
) /= N_Identifier
then
5161 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5163 end Check_Arg_Is_Identifier
;
5165 ----------------------------------
5166 -- Check_Arg_Is_Integer_Literal --
5167 ----------------------------------
5169 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5170 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5172 if Nkind
(Argx
) /= N_Integer_Literal
then
5174 ("argument for pragma% must be integer literal", Argx
);
5176 end Check_Arg_Is_Integer_Literal
;
5178 -------------------------------------------
5179 -- Check_Arg_Is_Library_Level_Local_Name --
5180 -------------------------------------------
5184 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5185 -- | library_unit_NAME
5187 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5189 Check_Arg_Is_Local_Name
(Arg
);
5191 -- If it came from an aspect, we want to give the error just as if it
5192 -- came from source.
5194 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5195 and then (Comes_From_Source
(N
)
5196 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5199 ("argument for pragma% must be library level entity", Arg
);
5201 end Check_Arg_Is_Library_Level_Local_Name
;
5203 -----------------------------
5204 -- Check_Arg_Is_Local_Name --
5205 -----------------------------
5209 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5210 -- | library_unit_NAME
5212 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5213 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5216 -- If this pragma came from an aspect specification, we don't want to
5217 -- check for this error, because that would cause spurious errors, in
5218 -- case a type is frozen in a scope more nested than the type. The
5219 -- aspect itself of course can't be anywhere but on the declaration
5222 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5223 if From_Aspect_Specification
(Parent
(Arg
)) then
5227 -- Arg is the Expression of an N_Pragma_Argument_Association
5230 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5237 if Nkind
(Argx
) not in N_Direct_Name
5238 and then (Nkind
(Argx
) /= N_Attribute_Reference
5239 or else Present
(Expressions
(Argx
))
5240 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5241 and then (not Is_Entity_Name
(Argx
)
5242 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5244 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5247 -- No further check required if not an entity name
5249 if not Is_Entity_Name
(Argx
) then
5255 Ent
: constant Entity_Id
:= Entity
(Argx
);
5256 Scop
: constant Entity_Id
:= Scope
(Ent
);
5259 -- Case of a pragma applied to a compilation unit: pragma must
5260 -- occur immediately after the program unit in the compilation.
5262 if Is_Compilation_Unit
(Ent
) then
5264 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5267 -- Case of pragma placed immediately after spec
5269 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5272 -- Case of pragma placed immediately after body
5274 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5275 and then Present
(Corresponding_Body
(Decl
))
5279 (Parent
(Unit_Declaration_Node
5280 (Corresponding_Body
(Decl
))));
5282 -- All other cases are illegal
5289 -- Special restricted placement rule from 10.2.1(11.8/2)
5291 elsif Is_Generic_Formal
(Ent
)
5292 and then Prag_Id
= Pragma_Preelaborable_Initialization
5294 OK
:= List_Containing
(N
) =
5295 Generic_Formal_Declarations
5296 (Unit_Declaration_Node
(Scop
));
5298 -- If this is an aspect applied to a subprogram body, the
5299 -- pragma is inserted in its declarative part.
5301 elsif From_Aspect_Specification
(N
)
5302 and then Ent
= Current_Scope
5304 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5308 -- If the aspect is a predicate (possibly others ???) and the
5309 -- context is a record type, this is a discriminant expression
5310 -- within a type declaration, that freezes the predicated
5313 elsif From_Aspect_Specification
(N
)
5314 and then Prag_Id
= Pragma_Predicate
5315 and then Ekind
(Current_Scope
) = E_Record_Type
5316 and then Scop
= Scope
(Current_Scope
)
5320 -- Default case, just check that the pragma occurs in the scope
5321 -- of the entity denoted by the name.
5324 OK
:= Current_Scope
= Scop
;
5329 ("pragma% argument must be in same declarative part", Arg
);
5333 end Check_Arg_Is_Local_Name
;
5335 ---------------------------------
5336 -- Check_Arg_Is_Locking_Policy --
5337 ---------------------------------
5339 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5340 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5343 Check_Arg_Is_Identifier
(Argx
);
5345 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5346 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5348 end Check_Arg_Is_Locking_Policy
;
5350 -----------------------------------------------
5351 -- Check_Arg_Is_Partition_Elaboration_Policy --
5352 -----------------------------------------------
5354 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5355 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5358 Check_Arg_Is_Identifier
(Argx
);
5360 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5362 ("& is not a valid partition elaboration policy name", Argx
);
5364 end Check_Arg_Is_Partition_Elaboration_Policy
;
5366 -------------------------
5367 -- Check_Arg_Is_One_Of --
5368 -------------------------
5370 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5371 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5374 Check_Arg_Is_Identifier
(Argx
);
5376 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5377 Error_Msg_Name_2
:= N1
;
5378 Error_Msg_Name_3
:= N2
;
5379 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5381 end Check_Arg_Is_One_Of
;
5383 procedure Check_Arg_Is_One_Of
5385 N1
, N2
, N3
: Name_Id
)
5387 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5390 Check_Arg_Is_Identifier
(Argx
);
5392 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5393 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5395 end Check_Arg_Is_One_Of
;
5397 procedure Check_Arg_Is_One_Of
5399 N1
, N2
, N3
, N4
: Name_Id
)
5401 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5404 Check_Arg_Is_Identifier
(Argx
);
5406 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5407 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5409 end Check_Arg_Is_One_Of
;
5411 procedure Check_Arg_Is_One_Of
5413 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5415 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5418 Check_Arg_Is_Identifier
(Argx
);
5420 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5421 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5423 end Check_Arg_Is_One_Of
;
5425 ---------------------------------
5426 -- Check_Arg_Is_Queuing_Policy --
5427 ---------------------------------
5429 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5430 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5433 Check_Arg_Is_Identifier
(Argx
);
5435 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5436 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5438 end Check_Arg_Is_Queuing_Policy
;
5440 ---------------------------------------
5441 -- Check_Arg_Is_OK_Static_Expression --
5442 ---------------------------------------
5444 procedure Check_Arg_Is_OK_Static_Expression
5446 Typ
: Entity_Id
:= Empty
)
5449 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5450 end Check_Arg_Is_OK_Static_Expression
;
5452 ------------------------------------------
5453 -- Check_Arg_Is_Task_Dispatching_Policy --
5454 ------------------------------------------
5456 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5457 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5460 Check_Arg_Is_Identifier
(Argx
);
5462 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5464 ("& is not an allowed task dispatching policy name", Argx
);
5466 end Check_Arg_Is_Task_Dispatching_Policy
;
5468 ---------------------
5469 -- Check_Arg_Order --
5470 ---------------------
5472 procedure Check_Arg_Order
(Names
: Name_List
) is
5475 Highest_So_Far
: Natural := 0;
5476 -- Highest index in Names seen do far
5480 for J
in 1 .. Arg_Count
loop
5481 if Chars
(Arg
) /= No_Name
then
5482 for K
in Names
'Range loop
5483 if Chars
(Arg
) = Names
(K
) then
5484 if K
< Highest_So_Far
then
5485 Error_Msg_Name_1
:= Pname
;
5487 ("parameters out of order for pragma%", Arg
);
5488 Error_Msg_Name_1
:= Names
(K
);
5489 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5490 Error_Msg_N
("\% must appear before %", Arg
);
5494 Highest_So_Far
:= K
;
5502 end Check_Arg_Order
;
5504 --------------------------------
5505 -- Check_At_Least_N_Arguments --
5506 --------------------------------
5508 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5510 if Arg_Count
< N
then
5511 Error_Pragma
("too few arguments for pragma%");
5513 end Check_At_Least_N_Arguments
;
5515 -------------------------------
5516 -- Check_At_Most_N_Arguments --
5517 -------------------------------
5519 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5522 if Arg_Count
> N
then
5524 for J
in 1 .. N
loop
5526 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5529 end Check_At_Most_N_Arguments
;
5531 ---------------------
5532 -- Check_Component --
5533 ---------------------
5535 procedure Check_Component
5538 In_Variant_Part
: Boolean := False)
5540 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5541 Sindic
: constant Node_Id
:=
5542 Subtype_Indication
(Component_Definition
(Comp
));
5543 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5546 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5547 -- object constraint, then the component type shall be an Unchecked_
5550 if Nkind
(Sindic
) = N_Subtype_Indication
5551 and then Has_Per_Object_Constraint
(Comp_Id
)
5552 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5555 ("component subtype subject to per-object constraint "
5556 & "must be an Unchecked_Union", Comp
);
5558 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5559 -- the body of a generic unit, or within the body of any of its
5560 -- descendant library units, no part of the type of a component
5561 -- declared in a variant_part of the unchecked union type shall be of
5562 -- a formal private type or formal private extension declared within
5563 -- the formal part of the generic unit.
5565 elsif Ada_Version
>= Ada_2012
5566 and then In_Generic_Body
(UU_Typ
)
5567 and then In_Variant_Part
5568 and then Is_Private_Type
(Typ
)
5569 and then Is_Generic_Type
(Typ
)
5572 ("component of unchecked union cannot be of generic type", Comp
);
5574 elsif Needs_Finalization
(Typ
) then
5576 ("component of unchecked union cannot be controlled", Comp
);
5578 elsif Has_Task
(Typ
) then
5580 ("component of unchecked union cannot have tasks", Comp
);
5582 end Check_Component
;
5584 ----------------------------
5585 -- Check_Duplicate_Pragma --
5586 ----------------------------
5588 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5589 Id
: Entity_Id
:= E
;
5593 -- Nothing to do if this pragma comes from an aspect specification,
5594 -- since we could not be duplicating a pragma, and we dealt with the
5595 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5597 if From_Aspect_Specification
(N
) then
5601 -- Otherwise current pragma may duplicate previous pragma or a
5602 -- previously given aspect specification or attribute definition
5603 -- clause for the same pragma.
5605 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5609 -- If the entity is a type, then we have to make sure that the
5610 -- ostensible duplicate is not for a parent type from which this
5614 if Nkind
(P
) = N_Pragma
then
5616 Args
: constant List_Id
:=
5617 Pragma_Argument_Associations
(P
);
5620 and then Is_Entity_Name
(Expression
(First
(Args
)))
5621 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5622 and then Entity
(Expression
(First
(Args
))) /= E
5628 elsif Nkind
(P
) = N_Aspect_Specification
5629 and then Is_Type
(Entity
(P
))
5630 and then Entity
(P
) /= E
5636 -- Here we have a definite duplicate
5638 Error_Msg_Name_1
:= Pragma_Name
(N
);
5639 Error_Msg_Sloc
:= Sloc
(P
);
5641 -- For a single protected or a single task object, the error is
5642 -- issued on the original entity.
5644 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5645 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5648 if Nkind
(P
) = N_Aspect_Specification
5649 or else From_Aspect_Specification
(P
)
5651 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5653 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5658 end Check_Duplicate_Pragma
;
5660 ----------------------------------
5661 -- Check_Duplicated_Export_Name --
5662 ----------------------------------
5664 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5665 String_Val
: constant String_Id
:= Strval
(Nam
);
5668 -- We are only interested in the export case, and in the case of
5669 -- generics, it is the instance, not the template, that is the
5670 -- problem (the template will generate a warning in any case).
5672 if not Inside_A_Generic
5673 and then (Prag_Id
= Pragma_Export
5675 Prag_Id
= Pragma_Export_Procedure
5677 Prag_Id
= Pragma_Export_Valued_Procedure
5679 Prag_Id
= Pragma_Export_Function
)
5681 for J
in Externals
.First
.. Externals
.Last
loop
5682 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5683 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5684 Error_Msg_N
("external name duplicates name given#", Nam
);
5689 Externals
.Append
(Nam
);
5691 end Check_Duplicated_Export_Name
;
5693 ----------------------------------------
5694 -- Check_Expr_Is_OK_Static_Expression --
5695 ----------------------------------------
5697 procedure Check_Expr_Is_OK_Static_Expression
5699 Typ
: Entity_Id
:= Empty
)
5702 if Present
(Typ
) then
5703 Analyze_And_Resolve
(Expr
, Typ
);
5705 Analyze_And_Resolve
(Expr
);
5708 -- An expression cannot be considered static if its resolution failed
5709 -- or if it's erroneous. Stop the analysis of the related pragma.
5711 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5714 elsif Is_OK_Static_Expression
(Expr
) then
5717 -- An interesting special case, if we have a string literal and we
5718 -- are in Ada 83 mode, then we allow it even though it will not be
5719 -- flagged as static. This allows the use of Ada 95 pragmas like
5720 -- Import in Ada 83 mode. They will of course be flagged with
5721 -- warnings as usual, but will not cause errors.
5723 elsif Ada_Version
= Ada_83
5724 and then Nkind
(Expr
) = N_String_Literal
5728 -- Finally, we have a real error
5731 Error_Msg_Name_1
:= Pname
;
5732 Flag_Non_Static_Expr
5733 (Fix_Error
("argument for pragma% must be a static expression!"),
5737 end Check_Expr_Is_OK_Static_Expression
;
5739 -------------------------
5740 -- Check_First_Subtype --
5741 -------------------------
5743 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5744 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5745 Ent
: constant Entity_Id
:= Entity
(Argx
);
5748 if Is_First_Subtype
(Ent
) then
5751 elsif Is_Type
(Ent
) then
5753 ("pragma% cannot apply to subtype", Argx
);
5755 elsif Is_Object
(Ent
) then
5757 ("pragma% cannot apply to object, requires a type", Argx
);
5761 ("pragma% cannot apply to&, requires a type", Argx
);
5763 end Check_First_Subtype
;
5765 ----------------------
5766 -- Check_Identifier --
5767 ----------------------
5769 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5772 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5774 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5775 Error_Msg_Name_1
:= Pname
;
5776 Error_Msg_Name_2
:= Id
;
5777 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5781 end Check_Identifier
;
5783 --------------------------------
5784 -- Check_Identifier_Is_One_Of --
5785 --------------------------------
5787 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5790 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5792 if Chars
(Arg
) = No_Name
then
5793 Error_Msg_Name_1
:= Pname
;
5794 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5797 elsif Chars
(Arg
) /= N1
5798 and then Chars
(Arg
) /= N2
5800 Error_Msg_Name_1
:= Pname
;
5801 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5805 end Check_Identifier_Is_One_Of
;
5807 ---------------------------
5808 -- Check_In_Main_Program --
5809 ---------------------------
5811 procedure Check_In_Main_Program
is
5812 P
: constant Node_Id
:= Parent
(N
);
5815 -- Must be in subprogram body
5817 if Nkind
(P
) /= N_Subprogram_Body
then
5818 Error_Pragma
("% pragma allowed only in subprogram");
5820 -- Otherwise warn if obviously not main program
5822 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5823 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5825 Error_Msg_Name_1
:= Pname
;
5827 ("??pragma% is only effective in main program", N
);
5829 end Check_In_Main_Program
;
5831 ---------------------------------------
5832 -- Check_Interrupt_Or_Attach_Handler --
5833 ---------------------------------------
5835 procedure Check_Interrupt_Or_Attach_Handler
is
5836 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5837 Handler_Proc
, Proc_Scope
: Entity_Id
;
5842 if Prag_Id
= Pragma_Interrupt_Handler
then
5843 Check_Restriction
(No_Dynamic_Attachment
, N
);
5846 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5847 Proc_Scope
:= Scope
(Handler_Proc
);
5849 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5851 ("argument of pragma% must be protected procedure", Arg1
);
5854 -- For pragma case (as opposed to access case), check placement.
5855 -- We don't need to do that for aspects, because we have the
5856 -- check that they aspect applies an appropriate procedure.
5858 if not From_Aspect_Specification
(N
)
5859 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5861 Error_Pragma
("pragma% must be in protected definition");
5864 if not Is_Library_Level_Entity
(Proc_Scope
) then
5866 ("argument for pragma% must be library level entity", Arg1
);
5869 -- AI05-0033: A pragma cannot appear within a generic body, because
5870 -- instance can be in a nested scope. The check that protected type
5871 -- is itself a library-level declaration is done elsewhere.
5873 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5874 -- handle code prior to AI-0033. Analysis tools typically are not
5875 -- interested in this pragma in any case, so no need to worry too
5876 -- much about its placement.
5878 if Inside_A_Generic
then
5879 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5880 and then In_Package_Body
(Scope
(Current_Scope
))
5881 and then not Relaxed_RM_Semantics
5883 Error_Pragma
("pragma% cannot be used inside a generic");
5886 end Check_Interrupt_Or_Attach_Handler
;
5888 ---------------------------------
5889 -- Check_Loop_Pragma_Placement --
5890 ---------------------------------
5892 procedure Check_Loop_Pragma_Placement
is
5893 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5894 -- Verify whether the current pragma is properly grouped with other
5895 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5896 -- related loop where the pragma appears.
5898 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5899 -- Determine whether an arbitrary statement Stmt denotes pragma
5900 -- Loop_Invariant or Loop_Variant.
5902 procedure Placement_Error
(Constr
: Node_Id
);
5903 pragma No_Return
(Placement_Error
);
5904 -- Node Constr denotes the last loop restricted construct before we
5905 -- encountered an illegal relation between enclosing constructs. Emit
5906 -- an error depending on what Constr was.
5908 --------------------------------
5909 -- Check_Loop_Pragma_Grouping --
5910 --------------------------------
5912 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5913 Stop_Search
: exception;
5914 -- This exception is used to terminate the recursive descent of
5915 -- routine Check_Grouping.
5917 procedure Check_Grouping
(L
: List_Id
);
5918 -- Find the first group of pragmas in list L and if successful,
5919 -- ensure that the current pragma is part of that group. The
5920 -- routine raises Stop_Search once such a check is performed to
5921 -- halt the recursive descent.
5923 procedure Grouping_Error
(Prag
: Node_Id
);
5924 pragma No_Return
(Grouping_Error
);
5925 -- Emit an error concerning the current pragma indicating that it
5926 -- should be placed after pragma Prag.
5928 --------------------
5929 -- Check_Grouping --
5930 --------------------
5932 procedure Check_Grouping
(L
: List_Id
) is
5935 Prag
: Node_Id
:= Empty
; -- init to avoid warning
5938 -- Inspect the list of declarations or statements looking for
5939 -- the first grouping of pragmas:
5942 -- pragma Loop_Invariant ...;
5943 -- pragma Loop_Variant ...;
5945 -- pragma Loop_Variant ...; -- current pragma
5947 -- If the current pragma is not in the grouping, then it must
5948 -- either appear in a different declarative or statement list
5949 -- or the construct at (1) is separating the pragma from the
5953 while Present
(Stmt
) loop
5955 -- First pragma of the first topmost grouping has been found
5957 if Is_Loop_Pragma
(Stmt
) then
5959 -- The group and the current pragma are not in the same
5960 -- declarative or statement list.
5962 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5963 Grouping_Error
(Stmt
);
5965 -- Try to reach the current pragma from the first pragma
5966 -- of the grouping while skipping other members:
5968 -- pragma Loop_Invariant ...; -- first pragma
5969 -- pragma Loop_Variant ...; -- member
5971 -- pragma Loop_Variant ...; -- current pragma
5974 while Present
(Stmt
) loop
5975 -- The current pragma is either the first pragma
5976 -- of the group or is a member of the group.
5977 -- Stop the search as the placement is legal.
5982 -- Skip group members, but keep track of the
5983 -- last pragma in the group.
5985 elsif Is_Loop_Pragma
(Stmt
) then
5988 -- Skip declarations and statements generated by
5989 -- the compiler during expansion. Note that some
5990 -- source statements (e.g. pragma Assert) may have
5991 -- been transformed so that they do not appear as
5992 -- coming from source anymore, so we instead look
5993 -- at their Original_Node.
5995 elsif not Comes_From_Source
(Original_Node
(Stmt
))
5999 -- A non-pragma is separating the group from the
6000 -- current pragma, the placement is illegal.
6003 Grouping_Error
(Prag
);
6009 -- If the traversal did not reach the current pragma,
6010 -- then the list must be malformed.
6012 raise Program_Error
;
6015 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6016 -- inside a loop or a block housed inside a loop. Inspect
6017 -- the declarations and statements of the block as they may
6018 -- contain the first grouping. This case follows the one for
6019 -- loop pragmas, as block statements which originate in a
6020 -- loop pragma (and so Is_Loop_Pragma will return True on
6021 -- that block statement) should be treated in the previous
6024 elsif Nkind
(Stmt
) = N_Block_Statement
then
6025 HSS
:= Handled_Statement_Sequence
(Stmt
);
6027 Check_Grouping
(Declarations
(Stmt
));
6029 if Present
(HSS
) then
6030 Check_Grouping
(Statements
(HSS
));
6038 --------------------
6039 -- Grouping_Error --
6040 --------------------
6042 procedure Grouping_Error
(Prag
: Node_Id
) is
6044 Error_Msg_Sloc
:= Sloc
(Prag
);
6045 Error_Pragma
("pragma% must appear next to pragma#");
6048 -- Start of processing for Check_Loop_Pragma_Grouping
6051 -- Inspect the statements of the loop or nested blocks housed
6052 -- within to determine whether the current pragma is part of the
6053 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6055 Check_Grouping
(Statements
(Loop_Stmt
));
6058 when Stop_Search
=> null;
6059 end Check_Loop_Pragma_Grouping
;
6061 --------------------
6062 -- Is_Loop_Pragma --
6063 --------------------
6065 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6067 -- Inspect the original node as Loop_Invariant and Loop_Variant
6068 -- pragmas are rewritten to null when assertions are disabled.
6070 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
6072 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
6073 Name_Loop_Invariant
,
6080 ---------------------
6081 -- Placement_Error --
6082 ---------------------
6084 procedure Placement_Error
(Constr
: Node_Id
) is
6085 LA
: constant String := " with Loop_Entry";
6088 if Prag_Id
= Pragma_Assert
then
6089 Error_Msg_String
(1 .. LA
'Length) := LA
;
6090 Error_Msg_Strlen
:= LA
'Length;
6092 Error_Msg_Strlen
:= 0;
6095 if Nkind
(Constr
) = N_Pragma
then
6097 ("pragma %~ must appear immediately within the statements "
6101 ("block containing pragma %~ must appear immediately within "
6102 & "the statements of a loop", Constr
);
6104 end Placement_Error
;
6106 -- Local declarations
6111 -- Start of processing for Check_Loop_Pragma_Placement
6114 -- Check that pragma appears immediately within a loop statement,
6115 -- ignoring intervening block statements.
6119 while Present
(Stmt
) loop
6121 -- The pragma or previous block must appear immediately within the
6122 -- current block's declarative or statement part.
6124 if Nkind
(Stmt
) = N_Block_Statement
then
6125 if (No
(Declarations
(Stmt
))
6126 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6128 List_Containing
(Prev
) /=
6129 Statements
(Handled_Statement_Sequence
(Stmt
))
6131 Placement_Error
(Prev
);
6134 -- Keep inspecting the parents because we are now within a
6135 -- chain of nested blocks.
6139 Stmt
:= Parent
(Stmt
);
6142 -- The pragma or previous block must appear immediately within the
6143 -- statements of the loop.
6145 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6146 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6147 Placement_Error
(Prev
);
6150 -- Stop the traversal because we reached the innermost loop
6151 -- regardless of whether we encountered an error or not.
6155 -- Ignore a handled statement sequence. Note that this node may
6156 -- be related to a subprogram body in which case we will emit an
6157 -- error on the next iteration of the search.
6159 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6160 Stmt
:= Parent
(Stmt
);
6162 -- Any other statement breaks the chain from the pragma to the
6166 Placement_Error
(Prev
);
6171 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6172 -- grouped together with other such pragmas.
6174 if Is_Loop_Pragma
(N
) then
6176 -- The previous check should have located the related loop
6178 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6179 Check_Loop_Pragma_Grouping
(Stmt
);
6181 end Check_Loop_Pragma_Placement
;
6183 -------------------------------------------
6184 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6185 -------------------------------------------
6187 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6196 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6199 elsif Nkind_In
(P
, N_Package_Specification
,
6204 -- Note: the following tests seem a little peculiar, because
6205 -- they test for bodies, but if we were in the statement part
6206 -- of the body, we would already have hit the handled statement
6207 -- sequence, so the only way we get here is by being in the
6208 -- declarative part of the body.
6210 elsif Nkind_In
(P
, N_Subprogram_Body
,
6221 Error_Pragma
("pragma% is not in declarative part or package spec");
6222 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6224 -------------------------
6225 -- Check_No_Identifier --
6226 -------------------------
6228 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6230 if Nkind
(Arg
) = N_Pragma_Argument_Association
6231 and then Chars
(Arg
) /= No_Name
6233 Error_Pragma_Arg_Ident
6234 ("pragma% does not permit identifier& here", Arg
);
6236 end Check_No_Identifier
;
6238 --------------------------
6239 -- Check_No_Identifiers --
6240 --------------------------
6242 procedure Check_No_Identifiers
is
6246 for J
in 1 .. Arg_Count
loop
6247 Check_No_Identifier
(Arg_Node
);
6250 end Check_No_Identifiers
;
6252 ------------------------
6253 -- Check_No_Link_Name --
6254 ------------------------
6256 procedure Check_No_Link_Name
is
6258 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6262 if Present
(Arg4
) then
6264 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6266 end Check_No_Link_Name
;
6268 -------------------------------
6269 -- Check_Optional_Identifier --
6270 -------------------------------
6272 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6275 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6276 and then Chars
(Arg
) /= No_Name
6278 if Chars
(Arg
) /= Id
then
6279 Error_Msg_Name_1
:= Pname
;
6280 Error_Msg_Name_2
:= Id
;
6281 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6285 end Check_Optional_Identifier
;
6287 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6289 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6290 end Check_Optional_Identifier
;
6292 -------------------------------------
6293 -- Check_Static_Boolean_Expression --
6294 -------------------------------------
6296 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6298 if Present
(Expr
) then
6299 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6301 if not Is_OK_Static_Expression
(Expr
) then
6303 ("expression of pragma % must be static", Expr
);
6306 end Check_Static_Boolean_Expression
;
6308 -----------------------------
6309 -- Check_Static_Constraint --
6310 -----------------------------
6312 -- Note: for convenience in writing this procedure, in addition to
6313 -- the officially (i.e. by spec) allowed argument which is always a
6314 -- constraint, it also allows ranges and discriminant associations.
6315 -- Above is not clear ???
6317 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6319 procedure Require_Static
(E
: Node_Id
);
6320 -- Require given expression to be static expression
6322 --------------------
6323 -- Require_Static --
6324 --------------------
6326 procedure Require_Static
(E
: Node_Id
) is
6328 if not Is_OK_Static_Expression
(E
) then
6329 Flag_Non_Static_Expr
6330 ("non-static constraint not allowed in Unchecked_Union!", E
);
6335 -- Start of processing for Check_Static_Constraint
6338 case Nkind
(Constr
) is
6339 when N_Discriminant_Association
=>
6340 Require_Static
(Expression
(Constr
));
6343 Require_Static
(Low_Bound
(Constr
));
6344 Require_Static
(High_Bound
(Constr
));
6346 when N_Attribute_Reference
=>
6347 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6348 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6350 when N_Range_Constraint
=>
6351 Check_Static_Constraint
(Range_Expression
(Constr
));
6353 when N_Index_Or_Discriminant_Constraint
=>
6357 IDC
:= First
(Constraints
(Constr
));
6358 while Present
(IDC
) loop
6359 Check_Static_Constraint
(IDC
);
6367 end Check_Static_Constraint
;
6369 --------------------------------------
6370 -- Check_Valid_Configuration_Pragma --
6371 --------------------------------------
6373 -- A configuration pragma must appear in the context clause of a
6374 -- compilation unit, and only other pragmas may precede it. Note that
6375 -- the test also allows use in a configuration pragma file.
6377 procedure Check_Valid_Configuration_Pragma
is
6379 if not Is_Configuration_Pragma
then
6380 Error_Pragma
("incorrect placement for configuration pragma%");
6382 end Check_Valid_Configuration_Pragma
;
6384 -------------------------------------
6385 -- Check_Valid_Library_Unit_Pragma --
6386 -------------------------------------
6388 procedure Check_Valid_Library_Unit_Pragma
is
6390 Parent_Node
: Node_Id
;
6391 Unit_Name
: Entity_Id
;
6392 Unit_Kind
: Node_Kind
;
6393 Unit_Node
: Node_Id
;
6394 Sindex
: Source_File_Index
;
6397 if not Is_List_Member
(N
) then
6401 Plist
:= List_Containing
(N
);
6402 Parent_Node
:= Parent
(Plist
);
6404 if Parent_Node
= Empty
then
6407 -- Case of pragma appearing after a compilation unit. In this case
6408 -- it must have an argument with the corresponding name and must
6409 -- be part of the following pragmas of its parent.
6411 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6412 if Plist
/= Pragmas_After
(Parent_Node
) then
6415 elsif Arg_Count
= 0 then
6417 ("argument required if outside compilation unit");
6420 Check_No_Identifiers
;
6421 Check_Arg_Count
(1);
6422 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6423 Unit_Kind
:= Nkind
(Unit_Node
);
6425 Analyze
(Get_Pragma_Arg
(Arg1
));
6427 if Unit_Kind
= N_Generic_Subprogram_Declaration
6428 or else Unit_Kind
= N_Subprogram_Declaration
6430 Unit_Name
:= Defining_Entity
(Unit_Node
);
6432 elsif Unit_Kind
in N_Generic_Instantiation
then
6433 Unit_Name
:= Defining_Entity
(Unit_Node
);
6436 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6439 if Chars
(Unit_Name
) /=
6440 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6443 ("pragma% argument is not current unit name", Arg1
);
6446 if Ekind
(Unit_Name
) = E_Package
6447 and then Present
(Renamed_Entity
(Unit_Name
))
6449 Error_Pragma
("pragma% not allowed for renamed package");
6453 -- Pragma appears other than after a compilation unit
6456 -- Here we check for the generic instantiation case and also
6457 -- for the case of processing a generic formal package. We
6458 -- detect these cases by noting that the Sloc on the node
6459 -- does not belong to the current compilation unit.
6461 Sindex
:= Source_Index
(Current_Sem_Unit
);
6463 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6464 Rewrite
(N
, Make_Null_Statement
(Loc
));
6467 -- If before first declaration, the pragma applies to the
6468 -- enclosing unit, and the name if present must be this name.
6470 elsif Is_Before_First_Decl
(N
, Plist
) then
6471 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6472 Unit_Kind
:= Nkind
(Unit_Node
);
6474 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6477 elsif Unit_Kind
= N_Subprogram_Body
6478 and then not Acts_As_Spec
(Unit_Node
)
6482 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6485 elsif Nkind
(Parent_Node
) = N_Package_Specification
6486 and then Plist
= Private_Declarations
(Parent_Node
)
6490 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6491 or else Nkind
(Parent_Node
) =
6492 N_Generic_Subprogram_Declaration
)
6493 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6497 elsif Arg_Count
> 0 then
6498 Analyze
(Get_Pragma_Arg
(Arg1
));
6500 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6502 ("name in pragma% must be enclosing unit", Arg1
);
6505 -- It is legal to have no argument in this context
6511 -- Error if not before first declaration. This is because a
6512 -- library unit pragma argument must be the name of a library
6513 -- unit (RM 10.1.5(7)), but the only names permitted in this
6514 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6515 -- generic subprogram declarations or generic instantiations.
6519 ("pragma% misplaced, must be before first declaration");
6523 end Check_Valid_Library_Unit_Pragma
;
6529 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6530 Clist
: constant Node_Id
:= Component_List
(Variant
);
6534 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6535 while Present
(Comp
) loop
6536 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6537 Next_Non_Pragma
(Comp
);
6541 ---------------------------
6542 -- Ensure_Aggregate_Form --
6543 ---------------------------
6545 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6546 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6547 Expr
: constant Node_Id
:= Expression
(Arg
);
6548 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6549 Comps
: List_Id
:= No_List
;
6550 Exprs
: List_Id
:= No_List
;
6551 Nam
: Name_Id
:= No_Name
;
6552 Nam_Loc
: Source_Ptr
;
6555 -- The pragma argument is in positional form:
6557 -- pragma Depends (Nam => ...)
6561 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6562 -- argument association.
6564 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6566 Nam_Loc
:= Sloc
(Arg
);
6568 -- Remove the pragma argument name as this will be captured in the
6571 Set_Chars
(Arg
, No_Name
);
6574 -- The argument is already in aggregate form, but the presence of a
6575 -- name causes this to be interpreted as named association which in
6576 -- turn must be converted into an aggregate.
6578 -- pragma Global (In_Out => (A, B, C))
6582 -- pragma Global ((In_Out => (A, B, C)))
6584 -- aggregate aggregate
6586 if Nkind
(Expr
) = N_Aggregate
then
6587 if Nam
= No_Name
then
6591 -- Do not transform a null argument into an aggregate as N_Null has
6592 -- special meaning in formal verification pragmas.
6594 elsif Nkind
(Expr
) = N_Null
then
6598 -- Everything comes from source if the original comes from source
6600 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6602 -- Positional argument is transformed into an aggregate with an
6603 -- Expressions list.
6605 if Nam
= No_Name
then
6606 Exprs
:= New_List
(Relocate_Node
(Expr
));
6608 -- An associative argument is transformed into an aggregate with
6609 -- Component_Associations.
6613 Make_Component_Association
(Loc
,
6614 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6615 Expression
=> Relocate_Node
(Expr
)));
6618 Set_Expression
(Arg
,
6619 Make_Aggregate
(Loc
,
6620 Component_Associations
=> Comps
,
6621 Expressions
=> Exprs
));
6623 -- Restore Comes_From_Source default
6625 Set_Comes_From_Source_Default
(CFSD
);
6626 end Ensure_Aggregate_Form
;
6632 procedure Error_Pragma
(Msg
: String) is
6634 Error_Msg_Name_1
:= Pname
;
6635 Error_Msg_N
(Fix_Error
(Msg
), N
);
6639 ----------------------
6640 -- Error_Pragma_Arg --
6641 ----------------------
6643 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6645 Error_Msg_Name_1
:= Pname
;
6646 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6648 end Error_Pragma_Arg
;
6650 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6652 Error_Msg_Name_1
:= Pname
;
6653 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6654 Error_Pragma_Arg
(Msg2
, Arg
);
6655 end Error_Pragma_Arg
;
6657 ----------------------------
6658 -- Error_Pragma_Arg_Ident --
6659 ----------------------------
6661 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6663 Error_Msg_Name_1
:= Pname
;
6664 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6666 end Error_Pragma_Arg_Ident
;
6668 ----------------------
6669 -- Error_Pragma_Ref --
6670 ----------------------
6672 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6674 Error_Msg_Name_1
:= Pname
;
6675 Error_Msg_Sloc
:= Sloc
(Ref
);
6676 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6678 end Error_Pragma_Ref
;
6680 ------------------------
6681 -- Find_Lib_Unit_Name --
6682 ------------------------
6684 function Find_Lib_Unit_Name
return Entity_Id
is
6686 -- Return inner compilation unit entity, for case of nested
6687 -- categorization pragmas. This happens in generic unit.
6689 if Nkind
(Parent
(N
)) = N_Package_Specification
6690 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6692 return Defining_Entity
(Parent
(N
));
6694 return Current_Scope
;
6696 end Find_Lib_Unit_Name
;
6698 ----------------------------
6699 -- Find_Program_Unit_Name --
6700 ----------------------------
6702 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6703 Unit_Name
: Entity_Id
;
6704 Unit_Kind
: Node_Kind
;
6705 P
: constant Node_Id
:= Parent
(N
);
6708 if Nkind
(P
) = N_Compilation_Unit
then
6709 Unit_Kind
:= Nkind
(Unit
(P
));
6711 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6712 N_Package_Declaration
)
6713 or else Unit_Kind
in N_Generic_Declaration
6715 Unit_Name
:= Defining_Entity
(Unit
(P
));
6717 if Chars
(Id
) = Chars
(Unit_Name
) then
6718 Set_Entity
(Id
, Unit_Name
);
6719 Set_Etype
(Id
, Etype
(Unit_Name
));
6721 Set_Etype
(Id
, Any_Type
);
6723 ("cannot find program unit referenced by pragma%");
6727 Set_Etype
(Id
, Any_Type
);
6728 Error_Pragma
("pragma% inapplicable to this unit");
6734 end Find_Program_Unit_Name
;
6736 -----------------------------------------
6737 -- Find_Unique_Parameterless_Procedure --
6738 -----------------------------------------
6740 function Find_Unique_Parameterless_Procedure
6742 Arg
: Node_Id
) return Entity_Id
6744 Proc
: Entity_Id
:= Empty
;
6747 -- The body of this procedure needs some comments ???
6749 if not Is_Entity_Name
(Name
) then
6751 ("argument of pragma% must be entity name", Arg
);
6753 elsif not Is_Overloaded
(Name
) then
6754 Proc
:= Entity
(Name
);
6756 if Ekind
(Proc
) /= E_Procedure
6757 or else Present
(First_Formal
(Proc
))
6760 ("argument of pragma% must be parameterless procedure", Arg
);
6765 Found
: Boolean := False;
6767 Index
: Interp_Index
;
6770 Get_First_Interp
(Name
, Index
, It
);
6771 while Present
(It
.Nam
) loop
6774 if Ekind
(Proc
) = E_Procedure
6775 and then No
(First_Formal
(Proc
))
6779 Set_Entity
(Name
, Proc
);
6780 Set_Is_Overloaded
(Name
, False);
6783 ("ambiguous handler name for pragma% ", Arg
);
6787 Get_Next_Interp
(Index
, It
);
6792 ("argument of pragma% must be parameterless procedure",
6795 Proc
:= Entity
(Name
);
6801 end Find_Unique_Parameterless_Procedure
;
6807 function Fix_Error
(Msg
: String) return String is
6808 Res
: String (Msg
'Range) := Msg
;
6809 Res_Last
: Natural := Msg
'Last;
6813 -- If we have a rewriting of another pragma, go to that pragma
6815 if Is_Rewrite_Substitution
(N
)
6816 and then Nkind
(Original_Node
(N
)) = N_Pragma
6818 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6821 -- Case where pragma comes from an aspect specification
6823 if From_Aspect_Specification
(N
) then
6825 -- Change appearence of "pragma" in message to "aspect"
6828 while J
<= Res_Last
- 5 loop
6829 if Res
(J
.. J
+ 5) = "pragma" then
6830 Res
(J
.. J
+ 5) := "aspect";
6838 -- Change "argument of" at start of message to "entity for"
6841 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6843 Res
(Res
'First .. Res
'First + 9) := "entity for";
6844 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6845 Res
(Res
'First + 11 .. Res_Last
);
6846 Res_Last
:= Res_Last
- 1;
6849 -- Change "argument" at start of message to "entity"
6852 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6854 Res
(Res
'First .. Res
'First + 5) := "entity";
6855 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6856 Res
(Res
'First + 8 .. Res_Last
);
6857 Res_Last
:= Res_Last
- 2;
6860 -- Get name from corresponding aspect
6862 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6865 -- Return possibly modified message
6867 return Res
(Res
'First .. Res_Last
);
6870 -------------------------
6871 -- Gather_Associations --
6872 -------------------------
6874 procedure Gather_Associations
6876 Args
: out Args_List
)
6881 -- Initialize all parameters to Empty
6883 for J
in Args
'Range loop
6887 -- That's all we have to do if there are no argument associations
6889 if No
(Pragma_Argument_Associations
(N
)) then
6893 -- Otherwise first deal with any positional parameters present
6895 Arg
:= First
(Pragma_Argument_Associations
(N
));
6896 for Index
in Args
'Range loop
6897 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6898 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6902 -- Positional parameters all processed, if any left, then we
6903 -- have too many positional parameters.
6905 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6907 ("too many positional associations for pragma%", Arg
);
6910 -- Process named parameters if any are present
6912 while Present
(Arg
) loop
6913 if Chars
(Arg
) = No_Name
then
6915 ("positional association cannot follow named association",
6919 for Index
in Names
'Range loop
6920 if Names
(Index
) = Chars
(Arg
) then
6921 if Present
(Args
(Index
)) then
6923 ("duplicate argument association for pragma%", Arg
);
6925 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6930 if Index
= Names
'Last then
6931 Error_Msg_Name_1
:= Pname
;
6932 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6934 -- Check for possible misspelling
6936 for Index1
in Names
'Range loop
6937 if Is_Bad_Spelling_Of
6938 (Chars
(Arg
), Names
(Index1
))
6940 Error_Msg_Name_1
:= Names
(Index1
);
6941 Error_Msg_N
-- CODEFIX
6942 ("\possible misspelling of%", Arg
);
6954 end Gather_Associations
;
6960 procedure GNAT_Pragma
is
6962 -- We need to check the No_Implementation_Pragmas restriction for
6963 -- the case of a pragma from source. Note that the case of aspects
6964 -- generating corresponding pragmas marks these pragmas as not being
6965 -- from source, so this test also catches that case.
6967 if Comes_From_Source
(N
) then
6968 Check_Restriction
(No_Implementation_Pragmas
, N
);
6972 --------------------------
6973 -- Is_Before_First_Decl --
6974 --------------------------
6976 function Is_Before_First_Decl
6977 (Pragma_Node
: Node_Id
;
6978 Decls
: List_Id
) return Boolean
6980 Item
: Node_Id
:= First
(Decls
);
6983 -- Only other pragmas can come before this pragma
6986 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6989 elsif Item
= Pragma_Node
then
6995 end Is_Before_First_Decl
;
6997 -----------------------------
6998 -- Is_Configuration_Pragma --
6999 -----------------------------
7001 -- A configuration pragma must appear in the context clause of a
7002 -- compilation unit, and only other pragmas may precede it. Note that
7003 -- the test below also permits use in a configuration pragma file.
7005 function Is_Configuration_Pragma
return Boolean is
7006 Lis
: constant List_Id
:= List_Containing
(N
);
7007 Par
: constant Node_Id
:= Parent
(N
);
7011 -- If no parent, then we are in the configuration pragma file,
7012 -- so the placement is definitely appropriate.
7017 -- Otherwise we must be in the context clause of a compilation unit
7018 -- and the only thing allowed before us in the context list is more
7019 -- configuration pragmas.
7021 elsif Nkind
(Par
) = N_Compilation_Unit
7022 and then Context_Items
(Par
) = Lis
7029 elsif Nkind
(Prg
) /= N_Pragma
then
7039 end Is_Configuration_Pragma
;
7041 --------------------------
7042 -- Is_In_Context_Clause --
7043 --------------------------
7045 function Is_In_Context_Clause
return Boolean is
7047 Parent_Node
: Node_Id
;
7050 if not Is_List_Member
(N
) then
7054 Plist
:= List_Containing
(N
);
7055 Parent_Node
:= Parent
(Plist
);
7057 if Parent_Node
= Empty
7058 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7059 or else Context_Items
(Parent_Node
) /= Plist
7066 end Is_In_Context_Clause
;
7068 ---------------------------------
7069 -- Is_Static_String_Expression --
7070 ---------------------------------
7072 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7073 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7074 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7077 Analyze_And_Resolve
(Argx
);
7079 -- Special case Ada 83, where the expression will never be static,
7080 -- but we will return true if we had a string literal to start with.
7082 if Ada_Version
= Ada_83
then
7085 -- Normal case, true only if we end up with a string literal that
7086 -- is marked as being the result of evaluating a static expression.
7089 return Is_OK_Static_Expression
(Argx
)
7090 and then Nkind
(Argx
) = N_String_Literal
;
7093 end Is_Static_String_Expression
;
7095 ----------------------
7096 -- Pragma_Misplaced --
7097 ----------------------
7099 procedure Pragma_Misplaced
is
7101 Error_Pragma
("incorrect placement of pragma%");
7102 end Pragma_Misplaced
;
7104 ------------------------------------------------
7105 -- Process_Atomic_Independent_Shared_Volatile --
7106 ------------------------------------------------
7108 procedure Process_Atomic_Independent_Shared_Volatile
is
7109 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
7110 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7112 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7113 -- Appropriately set flags on the given entity (either an array or
7114 -- record component, or an object declaration) according to the
7117 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7118 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7119 -- no explicit alignment was given, set alignment to unknown, since
7120 -- back end knows what the alignment requirements are for atomic and
7121 -- full access arrays. Note: this is necessary for derived types.
7123 -------------------------
7124 -- Check_VFA_Conflicts --
7125 -------------------------
7127 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7131 VFA_And_Atomic
: Boolean := False;
7132 -- Set True if atomic component present
7134 VFA_And_Aliased
: Boolean := False;
7135 -- Set True if aliased component present
7138 -- Fetch the type in case we are dealing with an object or
7141 if Is_Type
(Ent
) then
7144 pragma Assert
(Is_Object
(Ent
)
7146 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7151 -- Check Atomic and VFA used together
7153 if Prag_Id
= Pragma_Volatile_Full_Access
7154 or else Is_Volatile_Full_Access
(Ent
)
7156 if Prag_Id
= Pragma_Atomic
7157 or else Prag_Id
= Pragma_Shared
7158 or else Is_Atomic
(Ent
)
7160 VFA_And_Atomic
:= True;
7162 elsif Is_Array_Type
(Typ
) then
7163 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7165 -- Note: Has_Atomic_Components is not used below, as this flag
7166 -- represents the pragma of the same name, Atomic_Components,
7167 -- which only applies to arrays.
7169 elsif Is_Record_Type
(Typ
) then
7170 -- Attributes cannot be applied to discriminants, only
7171 -- regular record components.
7173 Comp
:= First_Component
(Typ
);
7174 while Present
(Comp
) loop
7176 or else Is_Atomic
(Typ
)
7178 VFA_And_Atomic
:= True;
7183 Next_Component
(Comp
);
7187 if VFA_And_Atomic
then
7189 ("cannot have Volatile_Full_Access and Atomic for same "
7194 -- Check for the application of VFA to an entity that has aliased
7197 if Prag_Id
= Pragma_Volatile_Full_Access
then
7198 if Is_Array_Type
(Typ
)
7199 and then Has_Aliased_Components
(Typ
)
7201 VFA_And_Aliased
:= True;
7203 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7204 -- and Has_Independent_Components, applies only to arrays.
7205 -- However, this flag does not have a corresponding pragma, so
7206 -- perhaps it should be possible to apply it to record types as
7207 -- well. Should this be done ???
7209 elsif Is_Record_Type
(Typ
) then
7210 -- It is possible to have an aliased discriminant, so they
7211 -- must be checked along with normal components.
7213 Comp
:= First_Component_Or_Discriminant
(Typ
);
7214 while Present
(Comp
) loop
7215 if Is_Aliased
(Comp
)
7216 or else Is_Aliased
(Etype
(Comp
))
7218 VFA_And_Aliased
:= True;
7219 Check_SPARK_05_Restriction
7220 ("aliased is not allowed", Comp
);
7225 Next_Component_Or_Discriminant
(Comp
);
7229 if VFA_And_Aliased
then
7231 ("cannot apply Volatile_Full_Access (aliased component "
7235 end Check_VFA_Conflicts
;
7237 ------------------------------
7238 -- Mark_Component_Or_Object --
7239 ------------------------------
7241 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7243 if Prag_Id
= Pragma_Atomic
7244 or else Prag_Id
= Pragma_Shared
7245 or else Prag_Id
= Pragma_Volatile_Full_Access
7247 if Prag_Id
= Pragma_Volatile_Full_Access
then
7248 Set_Is_Volatile_Full_Access
(Ent
);
7250 Set_Is_Atomic
(Ent
);
7253 -- If the object declaration has an explicit initialization, a
7254 -- temporary may have to be created to hold the expression, to
7255 -- ensure that access to the object remains atomic.
7257 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7258 and then Present
(Expression
(Parent
(Ent
)))
7260 Set_Has_Delayed_Freeze
(Ent
);
7264 -- Atomic/Shared/Volatile_Full_Access imply Independent
7266 if Prag_Id
/= Pragma_Volatile
then
7267 Set_Is_Independent
(Ent
);
7269 if Prag_Id
= Pragma_Independent
then
7270 Record_Independence_Check
(N
, Ent
);
7274 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7276 if Prag_Id
/= Pragma_Independent
then
7277 Set_Is_Volatile
(Ent
);
7278 Set_Treat_As_Volatile
(Ent
);
7280 end Mark_Component_Or_Object
;
7282 --------------------
7283 -- Set_Atomic_VFA --
7284 --------------------
7286 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7288 if Prag_Id
= Pragma_Volatile_Full_Access
then
7289 Set_Is_Volatile_Full_Access
(Ent
);
7291 Set_Is_Atomic
(Ent
);
7294 if not Has_Alignment_Clause
(Ent
) then
7295 Set_Alignment
(Ent
, Uint_0
);
7305 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7308 Check_Ada_83_Warning
;
7309 Check_No_Identifiers
;
7310 Check_Arg_Count
(1);
7311 Check_Arg_Is_Local_Name
(Arg1
);
7312 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7314 if Etype
(E_Arg
) = Any_Type
then
7318 E
:= Entity
(E_Arg
);
7320 -- A pragma that applies to a Ghost entity becomes Ghost for the
7321 -- purposes of legality checks and removal of ignored Ghost code.
7323 Mark_Ghost_Pragma
(N
, E
);
7325 -- Check duplicate before we chain ourselves
7327 Check_Duplicate_Pragma
(E
);
7329 -- Check appropriateness of the entity
7331 Decl
:= Declaration_Node
(E
);
7333 -- Deal with the case where the pragma/attribute is applied to a type
7336 if Rep_Item_Too_Early
(E
, N
)
7337 or else Rep_Item_Too_Late
(E
, N
)
7341 Check_First_Subtype
(Arg1
);
7344 -- Attribute belongs on the base type. If the view of the type is
7345 -- currently private, it also belongs on the underlying type.
7347 if Prag_Id
= Pragma_Atomic
7348 or else Prag_Id
= Pragma_Shared
7349 or else Prag_Id
= Pragma_Volatile_Full_Access
7352 Set_Atomic_VFA
(Base_Type
(E
));
7353 Set_Atomic_VFA
(Underlying_Type
(E
));
7356 -- Atomic/Shared/Volatile_Full_Access imply Independent
7358 if Prag_Id
/= Pragma_Volatile
then
7359 Set_Is_Independent
(E
);
7360 Set_Is_Independent
(Base_Type
(E
));
7361 Set_Is_Independent
(Underlying_Type
(E
));
7363 if Prag_Id
= Pragma_Independent
then
7364 Record_Independence_Check
(N
, Base_Type
(E
));
7368 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7370 if Prag_Id
/= Pragma_Independent
then
7371 Set_Is_Volatile
(E
);
7372 Set_Is_Volatile
(Base_Type
(E
));
7373 Set_Is_Volatile
(Underlying_Type
(E
));
7375 Set_Treat_As_Volatile
(E
);
7376 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7379 -- Apply Volatile to the composite type's individual components,
7382 if Prag_Id
= Pragma_Volatile
7383 and then Is_Record_Type
(Etype
(E
))
7388 Comp
:= First_Component
(E
);
7389 while Present
(Comp
) loop
7390 Mark_Component_Or_Object
(Comp
);
7392 Next_Component
(Comp
);
7397 -- Deal with the case where the pragma/attribute applies to a
7398 -- component or object declaration.
7400 elsif Nkind
(Decl
) = N_Object_Declaration
7401 or else (Nkind
(Decl
) = N_Component_Declaration
7402 and then Original_Record_Component
(E
) = E
)
7404 if Rep_Item_Too_Late
(E
, N
) then
7408 Mark_Component_Or_Object
(E
);
7410 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7413 -- Perform the checks needed to assure the proper use of the GNAT
7414 -- pragma Volatile_Full_Access.
7416 Check_VFA_Conflicts
(E
);
7418 -- The following check is only relevant when SPARK_Mode is on as
7419 -- this is not a standard Ada legality rule. Pragma Volatile can
7420 -- only apply to a full type declaration or an object declaration
7421 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7422 -- untagged derived types that are rewritten as subtypes of their
7423 -- respective root types.
7426 and then Prag_Id
= Pragma_Volatile
7427 and then not Nkind_In
(Original_Node
(Decl
),
7428 N_Full_Type_Declaration
,
7429 N_Object_Declaration
,
7430 N_Single_Protected_Declaration
,
7431 N_Single_Task_Declaration
)
7434 ("argument of pragma % must denote a full type or object "
7435 & "declaration", Arg1
);
7437 end Process_Atomic_Independent_Shared_Volatile
;
7439 -------------------------------------------
7440 -- Process_Compile_Time_Warning_Or_Error --
7441 -------------------------------------------
7443 procedure Process_Compile_Time_Warning_Or_Error
is
7444 Validation_Needed
: Boolean := False;
7446 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7447 -- Tree visitor that checks if N is an attribute reference that can
7448 -- be statically computed by the back end. Validation_Needed is set
7449 -- to True if found.
7455 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7457 if Nkind
(N
) = N_Attribute_Reference
7458 and then Is_Entity_Name
(Prefix
(N
))
7461 Attr_Id
: constant Attribute_Id
:=
7462 Get_Attribute_Id
(Attribute_Name
(N
));
7464 if Attr_Id
= Attribute_Alignment
7465 or else Attr_Id
= Attribute_Size
7467 Validation_Needed
:= True;
7475 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7479 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7481 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7484 Check_Arg_Count
(2);
7485 Check_No_Identifiers
;
7486 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7487 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7489 if Compile_Time_Known_Value
(Arg1x
) then
7490 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7492 -- Register the expression for its validation after the back end has
7493 -- been called if it has occurrences of attributes Size or Alignment
7494 -- (because they may be statically computed by the back end and hence
7495 -- the whole expression needs to be reevaluated).
7498 Check_Expression
(Arg1x
);
7500 if Validation_Needed
then
7501 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7504 end Process_Compile_Time_Warning_Or_Error
;
7506 ------------------------
7507 -- Process_Convention --
7508 ------------------------
7510 procedure Process_Convention
7511 (C
: out Convention_Id
;
7512 Ent
: out Entity_Id
)
7516 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7517 -- Called if we have more than one Export/Import/Convention pragma.
7518 -- This is generally illegal, but we have a special case of allowing
7519 -- Import and Interface to coexist if they specify the convention in
7520 -- a consistent manner. We are allowed to do this, since Interface is
7521 -- an implementation defined pragma, and we choose to do it since we
7522 -- know Rational allows this combination. S is the entity id of the
7523 -- subprogram in question. This procedure also sets the special flag
7524 -- Import_Interface_Present in both pragmas in the case where we do
7525 -- have matching Import and Interface pragmas.
7527 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7528 -- Set convention in entity E, and also flag that the entity has a
7529 -- convention pragma. If entity is for a private or incomplete type,
7530 -- also set convention and flag on underlying type. This procedure
7531 -- also deals with the special case of C_Pass_By_Copy convention,
7532 -- and error checks for inappropriate convention specification.
7534 -------------------------------
7535 -- Diagnose_Multiple_Pragmas --
7536 -------------------------------
7538 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7539 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7543 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7544 -- Decl is a pragma node. This function returns True if this
7545 -- pragma has a first argument that is an identifier with a
7546 -- Chars field corresponding to the Convention_Id C.
7548 function Same_Name
(Decl
: Node_Id
) return Boolean;
7549 -- Decl is a pragma node. This function returns True if this
7550 -- pragma has a second argument that is an identifier with a
7551 -- Chars field that matches the Chars of the current subprogram.
7553 ---------------------
7554 -- Same_Convention --
7555 ---------------------
7557 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7558 Arg1
: constant Node_Id
:=
7559 First
(Pragma_Argument_Associations
(Decl
));
7562 if Present
(Arg1
) then
7564 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7566 if Nkind
(Arg
) = N_Identifier
7567 and then Is_Convention_Name
(Chars
(Arg
))
7568 and then Get_Convention_Id
(Chars
(Arg
)) = C
7576 end Same_Convention
;
7582 function Same_Name
(Decl
: Node_Id
) return Boolean is
7583 Arg1
: constant Node_Id
:=
7584 First
(Pragma_Argument_Associations
(Decl
));
7592 Arg2
:= Next
(Arg1
);
7599 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7601 if Nkind
(Arg
) = N_Identifier
7602 and then Chars
(Arg
) = Chars
(S
)
7611 -- Start of processing for Diagnose_Multiple_Pragmas
7616 -- Definitely give message if we have Convention/Export here
7618 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7621 -- If we have an Import or Export, scan back from pragma to
7622 -- find any previous pragma applying to the same procedure.
7623 -- The scan will be terminated by the start of the list, or
7624 -- hitting the subprogram declaration. This won't allow one
7625 -- pragma to appear in the public part and one in the private
7626 -- part, but that seems very unlikely in practice.
7630 while Present
(Decl
) and then Decl
/= Pdec
loop
7632 -- Look for pragma with same name as us
7634 if Nkind
(Decl
) = N_Pragma
7635 and then Same_Name
(Decl
)
7637 -- Give error if same as our pragma or Export/Convention
7639 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7642 Pragma_Name_Unmapped
(N
))
7646 -- Case of Import/Interface or the other way round
7648 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7649 Name_Interface
, Name_Import
)
7651 -- Here we know that we have Import and Interface. It
7652 -- doesn't matter which way round they are. See if
7653 -- they specify the same convention. If so, all OK,
7654 -- and set special flags to stop other messages
7656 if Same_Convention
(Decl
) then
7657 Set_Import_Interface_Present
(N
);
7658 Set_Import_Interface_Present
(Decl
);
7661 -- If different conventions, special message
7664 Error_Msg_Sloc
:= Sloc
(Decl
);
7666 ("convention differs from that given#", Arg1
);
7676 -- Give message if needed if we fall through those tests
7677 -- except on Relaxed_RM_Semantics where we let go: either this
7678 -- is a case accepted/ignored by other Ada compilers (e.g.
7679 -- a mix of Convention and Import), or another error will be
7680 -- generated later (e.g. using both Import and Export).
7682 if Err
and not Relaxed_RM_Semantics
then
7684 ("at most one Convention/Export/Import pragma is allowed",
7687 end Diagnose_Multiple_Pragmas
;
7689 --------------------------------
7690 -- Set_Convention_From_Pragma --
7691 --------------------------------
7693 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7695 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7696 -- for an overridden dispatching operation. Technically this is
7697 -- an amendment and should only be done in Ada 2005 mode. However,
7698 -- this is clearly a mistake, since the problem that is addressed
7699 -- by this AI is that there is a clear gap in the RM.
7701 if Is_Dispatching_Operation
(E
)
7702 and then Present
(Overridden_Operation
(E
))
7703 and then C
/= Convention
(Overridden_Operation
(E
))
7706 ("cannot change convention for overridden dispatching "
7707 & "operation", Arg1
);
7710 -- Special checks for Convention_Stdcall
7712 if C
= Convention_Stdcall
then
7714 -- A dispatching call is not allowed. A dispatching subprogram
7715 -- cannot be used to interface to the Win32 API, so in fact
7716 -- this check does not impose any effective restriction.
7718 if Is_Dispatching_Operation
(E
) then
7719 Error_Msg_Sloc
:= Sloc
(E
);
7721 -- Note: make this unconditional so that if there is more
7722 -- than one call to which the pragma applies, we get a
7723 -- message for each call. Also don't use Error_Pragma,
7724 -- so that we get multiple messages.
7727 ("dispatching subprogram# cannot use Stdcall convention!",
7730 -- Several allowed cases
7732 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7736 or else Ekind
(E
) = E_Variable
7738 -- A component as well. The entity does not have its Ekind
7739 -- set until the enclosing record declaration is fully
7742 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7744 -- An access to subprogram is also allowed
7748 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7750 -- Allow internal call to set convention of subprogram type
7752 or else Ekind
(E
) = E_Subprogram_Type
7758 ("second argument of pragma% must be subprogram (type)",
7763 -- Set the convention
7765 Set_Convention
(E
, C
);
7766 Set_Has_Convention_Pragma
(E
);
7768 -- For the case of a record base type, also set the convention of
7769 -- any anonymous access types declared in the record which do not
7770 -- currently have a specified convention.
7772 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7777 Comp
:= First_Component
(E
);
7778 while Present
(Comp
) loop
7779 if Present
(Etype
(Comp
))
7780 and then Ekind_In
(Etype
(Comp
),
7781 E_Anonymous_Access_Type
,
7782 E_Anonymous_Access_Subprogram_Type
)
7783 and then not Has_Convention_Pragma
(Comp
)
7785 Set_Convention
(Comp
, C
);
7788 Next_Component
(Comp
);
7793 -- Deal with incomplete/private type case, where underlying type
7794 -- is available, so set convention of that underlying type.
7796 if Is_Incomplete_Or_Private_Type
(E
)
7797 and then Present
(Underlying_Type
(E
))
7799 Set_Convention
(Underlying_Type
(E
), C
);
7800 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7803 -- A class-wide type should inherit the convention of the specific
7804 -- root type (although this isn't specified clearly by the RM).
7806 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7807 Set_Convention
(Class_Wide_Type
(E
), C
);
7810 -- If the entity is a record type, then check for special case of
7811 -- C_Pass_By_Copy, which is treated the same as C except that the
7812 -- special record flag is set. This convention is only permitted
7813 -- on record types (see AI95-00131).
7815 if Cname
= Name_C_Pass_By_Copy
then
7816 if Is_Record_Type
(E
) then
7817 Set_C_Pass_By_Copy
(Base_Type
(E
));
7818 elsif Is_Incomplete_Or_Private_Type
(E
)
7819 and then Is_Record_Type
(Underlying_Type
(E
))
7821 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7824 ("C_Pass_By_Copy convention allowed only for record type",
7829 -- If the entity is a derived boolean type, check for the special
7830 -- case of convention C, C++, or Fortran, where we consider any
7831 -- nonzero value to represent true.
7833 if Is_Discrete_Type
(E
)
7834 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7840 C
= Convention_Fortran
)
7842 Set_Nonzero_Is_True
(Base_Type
(E
));
7844 end Set_Convention_From_Pragma
;
7848 Comp_Unit
: Unit_Number_Type
;
7853 -- Start of processing for Process_Convention
7856 Check_At_Least_N_Arguments
(2);
7857 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7858 Check_Arg_Is_Identifier
(Arg1
);
7859 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7861 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7862 -- tested again below to set the critical flag).
7864 if Cname
= Name_C_Pass_By_Copy
then
7867 -- Otherwise we must have something in the standard convention list
7869 elsif Is_Convention_Name
(Cname
) then
7870 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7872 -- Otherwise warn on unrecognized convention
7875 if Warn_On_Export_Import
then
7877 ("??unrecognized convention name, C assumed",
7878 Get_Pragma_Arg
(Arg1
));
7884 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7885 Check_Arg_Is_Local_Name
(Arg2
);
7887 Id
:= Get_Pragma_Arg
(Arg2
);
7890 if not Is_Entity_Name
(Id
) then
7891 Error_Pragma_Arg
("entity name required", Arg2
);
7896 -- Set entity to return
7900 -- Ada_Pass_By_Copy special checking
7902 if C
= Convention_Ada_Pass_By_Copy
then
7903 if not Is_First_Subtype
(E
) then
7905 ("convention `Ada_Pass_By_Copy` only allowed for types",
7909 if Is_By_Reference_Type
(E
) then
7911 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7915 -- Ada_Pass_By_Reference special checking
7917 elsif C
= Convention_Ada_Pass_By_Reference
then
7918 if not Is_First_Subtype
(E
) then
7920 ("convention `Ada_Pass_By_Reference` only allowed for types",
7924 if Is_By_Copy_Type
(E
) then
7926 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7931 -- Go to renamed subprogram if present, since convention applies to
7932 -- the actual renamed entity, not to the renaming entity. If the
7933 -- subprogram is inherited, go to parent subprogram.
7935 if Is_Subprogram
(E
)
7936 and then Present
(Alias
(E
))
7938 if Nkind
(Parent
(Declaration_Node
(E
))) =
7939 N_Subprogram_Renaming_Declaration
7941 if Scope
(E
) /= Scope
(Alias
(E
)) then
7943 ("cannot apply pragma% to non-local entity&#", E
);
7948 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7949 N_Private_Extension_Declaration
)
7950 and then Scope
(E
) = Scope
(Alias
(E
))
7954 -- Return the parent subprogram the entity was inherited from
7960 -- Check that we are not applying this to a specless body. Relax this
7961 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7963 if Is_Subprogram
(E
)
7964 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7965 and then not Relaxed_RM_Semantics
7968 ("pragma% requires separate spec and must come before body");
7971 -- Check that we are not applying this to a named constant
7973 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7974 Error_Msg_Name_1
:= Pname
;
7976 ("cannot apply pragma% to named constant!",
7977 Get_Pragma_Arg
(Arg2
));
7979 ("\supply appropriate type for&!", Arg2
);
7982 if Ekind
(E
) = E_Enumeration_Literal
then
7983 Error_Pragma
("enumeration literal not allowed for pragma%");
7986 -- Check for rep item appearing too early or too late
7988 if Etype
(E
) = Any_Type
7989 or else Rep_Item_Too_Early
(E
, N
)
7993 elsif Present
(Underlying_Type
(E
)) then
7994 E
:= Underlying_Type
(E
);
7997 if Rep_Item_Too_Late
(E
, N
) then
8001 if Has_Convention_Pragma
(E
) then
8002 Diagnose_Multiple_Pragmas
(E
);
8004 elsif Convention
(E
) = Convention_Protected
8005 or else Ekind
(Scope
(E
)) = E_Protected_Type
8008 ("a protected operation cannot be given a different convention",
8012 -- For Intrinsic, a subprogram is required
8014 if C
= Convention_Intrinsic
8015 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8017 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8019 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8021 ("second argument of pragma% must be a subprogram", Arg2
);
8025 -- Deal with non-subprogram cases
8027 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8028 Set_Convention_From_Pragma
(E
);
8032 -- The pragma must apply to a first subtype, but it can also
8033 -- apply to a generic type in a generic formal part, in which
8034 -- case it will also appear in the corresponding instance.
8036 if Is_Generic_Type
(E
) or else In_Instance
then
8039 Check_First_Subtype
(Arg2
);
8042 Set_Convention_From_Pragma
(Base_Type
(E
));
8044 -- For access subprograms, we must set the convention on the
8045 -- internally generated directly designated type as well.
8047 if Ekind
(E
) = E_Access_Subprogram_Type
then
8048 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8052 -- For the subprogram case, set proper convention for all homonyms
8053 -- in same scope and the same declarative part, i.e. the same
8054 -- compilation unit.
8057 Comp_Unit
:= Get_Source_Unit
(E
);
8058 Set_Convention_From_Pragma
(E
);
8060 -- Treat a pragma Import as an implicit body, and pragma import
8061 -- as implicit reference (for navigation in GPS).
8063 if Prag_Id
= Pragma_Import
then
8064 Generate_Reference
(E
, Id
, 'b');
8066 -- For exported entities we restrict the generation of references
8067 -- to entities exported to foreign languages since entities
8068 -- exported to Ada do not provide further information to GPS and
8069 -- add undesired references to the output of the gnatxref tool.
8071 elsif Prag_Id
= Pragma_Export
8072 and then Convention
(E
) /= Convention_Ada
8074 Generate_Reference
(E
, Id
, 'i');
8077 -- If the pragma comes from an aspect, it only applies to the
8078 -- given entity, not its homonyms.
8080 if From_Aspect_Specification
(N
) then
8081 if C
= Convention_Intrinsic
8082 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8084 if Is_Fixed_Point_Type
(Etype
(Ent
))
8085 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8086 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8089 ("no intrinsic operator available for this fixed-point "
8092 ("\use expression functions with the desired "
8093 & "conversions made explicit", N
);
8100 -- Otherwise Loop through the homonyms of the pragma argument's
8101 -- entity, an apply convention to those in the current scope.
8107 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8109 -- Ignore entry for which convention is already set
8111 if Has_Convention_Pragma
(E1
) then
8115 if Is_Subprogram
(E1
)
8116 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8118 and then not Relaxed_RM_Semantics
8120 Set_Has_Completion
(E
); -- to prevent cascaded error
8122 ("pragma% requires separate spec and must come before "
8126 -- Do not set the pragma on inherited operations or on formal
8129 if Comes_From_Source
(E1
)
8130 and then Comp_Unit
= Get_Source_Unit
(E1
)
8131 and then not Is_Formal_Subprogram
(E1
)
8132 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8133 N_Full_Type_Declaration
8135 if Present
(Alias
(E1
))
8136 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8139 ("cannot apply pragma% to non-local entity& declared#",
8143 Set_Convention_From_Pragma
(E1
);
8145 if Prag_Id
= Pragma_Import
then
8146 Generate_Reference
(E1
, Id
, 'b');
8154 end Process_Convention
;
8156 ----------------------------------------
8157 -- Process_Disable_Enable_Atomic_Sync --
8158 ----------------------------------------
8160 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8162 Check_No_Identifiers
;
8163 Check_At_Most_N_Arguments
(1);
8165 -- Modeled internally as
8166 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8171 Pragma_Argument_Associations
=> New_List
(
8172 Make_Pragma_Argument_Association
(Loc
,
8174 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8176 if Present
(Arg1
) then
8177 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8181 end Process_Disable_Enable_Atomic_Sync
;
8183 -------------------------------------------------
8184 -- Process_Extended_Import_Export_Internal_Arg --
8185 -------------------------------------------------
8187 procedure Process_Extended_Import_Export_Internal_Arg
8188 (Arg_Internal
: Node_Id
:= Empty
)
8191 if No
(Arg_Internal
) then
8192 Error_Pragma
("Internal parameter required for pragma%");
8195 if Nkind
(Arg_Internal
) = N_Identifier
then
8198 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8199 and then (Prag_Id
= Pragma_Import_Function
8201 Prag_Id
= Pragma_Export_Function
)
8207 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8210 Check_Arg_Is_Local_Name
(Arg_Internal
);
8211 end Process_Extended_Import_Export_Internal_Arg
;
8213 --------------------------------------------------
8214 -- Process_Extended_Import_Export_Object_Pragma --
8215 --------------------------------------------------
8217 procedure Process_Extended_Import_Export_Object_Pragma
8218 (Arg_Internal
: Node_Id
;
8219 Arg_External
: Node_Id
;
8225 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8226 Def_Id
:= Entity
(Arg_Internal
);
8228 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8230 ("pragma% must designate an object", Arg_Internal
);
8233 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8235 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8238 ("previous Common/Psect_Object applies, pragma % not permitted",
8242 if Rep_Item_Too_Late
(Def_Id
, N
) then
8246 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8248 if Present
(Arg_Size
) then
8249 Check_Arg_Is_External_Name
(Arg_Size
);
8252 -- Export_Object case
8254 if Prag_Id
= Pragma_Export_Object
then
8255 if not Is_Library_Level_Entity
(Def_Id
) then
8257 ("argument for pragma% must be library level entity",
8261 if Ekind
(Current_Scope
) = E_Generic_Package
then
8262 Error_Pragma
("pragma& cannot appear in a generic unit");
8265 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8267 ("exported object must have compile time known size",
8271 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8272 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8274 Set_Exported
(Def_Id
, Arg_Internal
);
8277 -- Import_Object case
8280 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8282 ("cannot use pragma% for task/protected object",
8286 if Ekind
(Def_Id
) = E_Constant
then
8288 ("cannot import a constant", Arg_Internal
);
8291 if Warn_On_Export_Import
8292 and then Has_Discriminants
(Etype
(Def_Id
))
8295 ("imported value must be initialized??", Arg_Internal
);
8298 if Warn_On_Export_Import
8299 and then Is_Access_Type
(Etype
(Def_Id
))
8302 ("cannot import object of an access type??", Arg_Internal
);
8305 if Warn_On_Export_Import
8306 and then Is_Imported
(Def_Id
)
8308 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8310 -- Check for explicit initialization present. Note that an
8311 -- initialization generated by the code generator, e.g. for an
8312 -- access type, does not count here.
8314 elsif Present
(Expression
(Parent
(Def_Id
)))
8317 (Original_Node
(Expression
(Parent
(Def_Id
))))
8319 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8321 ("imported entities cannot be initialized (RM B.1(24))",
8322 "\no initialization allowed for & declared#", Arg1
);
8324 Set_Imported
(Def_Id
);
8325 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8328 end Process_Extended_Import_Export_Object_Pragma
;
8330 ------------------------------------------------------
8331 -- Process_Extended_Import_Export_Subprogram_Pragma --
8332 ------------------------------------------------------
8334 procedure Process_Extended_Import_Export_Subprogram_Pragma
8335 (Arg_Internal
: Node_Id
;
8336 Arg_External
: Node_Id
;
8337 Arg_Parameter_Types
: Node_Id
;
8338 Arg_Result_Type
: Node_Id
:= Empty
;
8339 Arg_Mechanism
: Node_Id
;
8340 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8346 Ambiguous
: Boolean;
8349 function Same_Base_Type
8351 Formal
: Entity_Id
) return Boolean;
8352 -- Determines if Ptype references the type of Formal. Note that only
8353 -- the base types need to match according to the spec. Ptype here is
8354 -- the argument from the pragma, which is either a type name, or an
8355 -- access attribute.
8357 --------------------
8358 -- Same_Base_Type --
8359 --------------------
8361 function Same_Base_Type
8363 Formal
: Entity_Id
) return Boolean
8365 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8369 -- Case where pragma argument is typ'Access
8371 if Nkind
(Ptype
) = N_Attribute_Reference
8372 and then Attribute_Name
(Ptype
) = Name_Access
8374 Pref
:= Prefix
(Ptype
);
8377 if not Is_Entity_Name
(Pref
)
8378 or else Entity
(Pref
) = Any_Type
8383 -- We have a match if the corresponding argument is of an
8384 -- anonymous access type, and its designated type matches the
8385 -- type of the prefix of the access attribute
8387 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8388 and then Base_Type
(Entity
(Pref
)) =
8389 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8391 -- Case where pragma argument is a type name
8396 if not Is_Entity_Name
(Ptype
)
8397 or else Entity
(Ptype
) = Any_Type
8402 -- We have a match if the corresponding argument is of the type
8403 -- given in the pragma (comparing base types)
8405 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8409 -- Start of processing for
8410 -- Process_Extended_Import_Export_Subprogram_Pragma
8413 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8417 -- Loop through homonyms (overloadings) of the entity
8419 Hom_Id
:= Entity
(Arg_Internal
);
8420 while Present
(Hom_Id
) loop
8421 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8423 -- We need a subprogram in the current scope
8425 if not Is_Subprogram
(Def_Id
)
8426 or else Scope
(Def_Id
) /= Current_Scope
8433 -- Pragma cannot apply to subprogram body
8435 if Is_Subprogram
(Def_Id
)
8436 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8440 ("pragma% requires separate spec and must come before "
8444 -- Test result type if given, note that the result type
8445 -- parameter can only be present for the function cases.
8447 if Present
(Arg_Result_Type
)
8448 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8452 elsif Etype
(Def_Id
) /= Standard_Void_Type
8453 and then Nam_In
(Pname
, Name_Export_Procedure
,
8454 Name_Import_Procedure
)
8458 -- Test parameter types if given. Note that this parameter has
8459 -- not been analyzed (and must not be, since it is semantic
8460 -- nonsense), so we get it as the parser left it.
8462 elsif Present
(Arg_Parameter_Types
) then
8463 Check_Matching_Types
: declare
8468 Formal
:= First_Formal
(Def_Id
);
8470 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8471 if Present
(Formal
) then
8475 -- A list of one type, e.g. (List) is parsed as a
8476 -- parenthesized expression.
8478 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8479 and then Paren_Count
(Arg_Parameter_Types
) = 1
8482 or else Present
(Next_Formal
(Formal
))
8487 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8490 -- A list of more than one type is parsed as a aggregate
8492 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8493 and then Paren_Count
(Arg_Parameter_Types
) = 0
8495 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8496 while Present
(Ptype
) or else Present
(Formal
) loop
8499 or else not Same_Base_Type
(Ptype
, Formal
)
8504 Next_Formal
(Formal
);
8509 -- Anything else is of the wrong form
8513 ("wrong form for Parameter_Types parameter",
8514 Arg_Parameter_Types
);
8516 end Check_Matching_Types
;
8519 -- Match is now False if the entry we found did not match
8520 -- either a supplied Parameter_Types or Result_Types argument
8526 -- Ambiguous case, the flag Ambiguous shows if we already
8527 -- detected this and output the initial messages.
8530 if not Ambiguous
then
8532 Error_Msg_Name_1
:= Pname
;
8534 ("pragma% does not uniquely identify subprogram!",
8536 Error_Msg_Sloc
:= Sloc
(Ent
);
8537 Error_Msg_N
("matching subprogram #!", N
);
8541 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8542 Error_Msg_N
("matching subprogram #!", N
);
8547 Hom_Id
:= Homonym
(Hom_Id
);
8550 -- See if we found an entry
8553 if not Ambiguous
then
8554 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8556 ("pragma% cannot be given for generic subprogram");
8559 ("pragma% does not identify local subprogram");
8566 -- Import pragmas must be for imported entities
8568 if Prag_Id
= Pragma_Import_Function
8570 Prag_Id
= Pragma_Import_Procedure
8572 Prag_Id
= Pragma_Import_Valued_Procedure
8574 if not Is_Imported
(Ent
) then
8576 ("pragma Import or Interface must precede pragma%");
8579 -- Here we have the Export case which can set the entity as exported
8581 -- But does not do so if the specified external name is null, since
8582 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8583 -- compatible) to request no external name.
8585 elsif Nkind
(Arg_External
) = N_String_Literal
8586 and then String_Length
(Strval
(Arg_External
)) = 0
8590 -- In all other cases, set entity as exported
8593 Set_Exported
(Ent
, Arg_Internal
);
8596 -- Special processing for Valued_Procedure cases
8598 if Prag_Id
= Pragma_Import_Valued_Procedure
8600 Prag_Id
= Pragma_Export_Valued_Procedure
8602 Formal
:= First_Formal
(Ent
);
8605 Error_Pragma
("at least one parameter required for pragma%");
8607 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8608 Error_Pragma
("first parameter must have mode out for pragma%");
8611 Set_Is_Valued_Procedure
(Ent
);
8615 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8617 -- Process Result_Mechanism argument if present. We have already
8618 -- checked that this is only allowed for the function case.
8620 if Present
(Arg_Result_Mechanism
) then
8621 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8624 -- Process Mechanism parameter if present. Note that this parameter
8625 -- is not analyzed, and must not be analyzed since it is semantic
8626 -- nonsense, so we get it in exactly as the parser left it.
8628 if Present
(Arg_Mechanism
) then
8636 -- A single mechanism association without a formal parameter
8637 -- name is parsed as a parenthesized expression. All other
8638 -- cases are parsed as aggregates, so we rewrite the single
8639 -- parameter case as an aggregate for consistency.
8641 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8642 and then Paren_Count
(Arg_Mechanism
) = 1
8644 Rewrite
(Arg_Mechanism
,
8645 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8646 Expressions
=> New_List
(
8647 Relocate_Node
(Arg_Mechanism
))));
8650 -- Case of only mechanism name given, applies to all formals
8652 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8653 Formal
:= First_Formal
(Ent
);
8654 while Present
(Formal
) loop
8655 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8656 Next_Formal
(Formal
);
8659 -- Case of list of mechanism associations given
8662 if Null_Record_Present
(Arg_Mechanism
) then
8664 ("inappropriate form for Mechanism parameter",
8668 -- Deal with positional ones first
8670 Formal
:= First_Formal
(Ent
);
8672 if Present
(Expressions
(Arg_Mechanism
)) then
8673 Mname
:= First
(Expressions
(Arg_Mechanism
));
8674 while Present
(Mname
) loop
8677 ("too many mechanism associations", Mname
);
8680 Set_Mechanism_Value
(Formal
, Mname
);
8681 Next_Formal
(Formal
);
8686 -- Deal with named entries
8688 if Present
(Component_Associations
(Arg_Mechanism
)) then
8689 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8690 while Present
(Massoc
) loop
8691 Choice
:= First
(Choices
(Massoc
));
8693 if Nkind
(Choice
) /= N_Identifier
8694 or else Present
(Next
(Choice
))
8697 ("incorrect form for mechanism association",
8701 Formal
:= First_Formal
(Ent
);
8705 ("parameter name & not present", Choice
);
8708 if Chars
(Choice
) = Chars
(Formal
) then
8710 (Formal
, Expression
(Massoc
));
8712 -- Set entity on identifier (needed by ASIS)
8714 Set_Entity
(Choice
, Formal
);
8719 Next_Formal
(Formal
);
8728 end Process_Extended_Import_Export_Subprogram_Pragma
;
8730 --------------------------
8731 -- Process_Generic_List --
8732 --------------------------
8734 procedure Process_Generic_List
is
8739 Check_No_Identifiers
;
8740 Check_At_Least_N_Arguments
(1);
8742 -- Check all arguments are names of generic units or instances
8745 while Present
(Arg
) loop
8746 Exp
:= Get_Pragma_Arg
(Arg
);
8749 if not Is_Entity_Name
(Exp
)
8751 (not Is_Generic_Instance
(Entity
(Exp
))
8753 not Is_Generic_Unit
(Entity
(Exp
)))
8756 ("pragma% argument must be name of generic unit/instance",
8762 end Process_Generic_List
;
8764 ------------------------------------
8765 -- Process_Import_Predefined_Type --
8766 ------------------------------------
8768 procedure Process_Import_Predefined_Type
is
8769 Loc
: constant Source_Ptr
:= Sloc
(N
);
8771 Ftyp
: Node_Id
:= Empty
;
8777 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8779 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8780 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8784 Ftyp
:= Node
(Elmt
);
8786 if Present
(Ftyp
) then
8788 -- Don't build a derived type declaration, because predefined C
8789 -- types have no declaration anywhere, so cannot really be named.
8790 -- Instead build a full type declaration, starting with an
8791 -- appropriate type definition is built
8793 if Is_Floating_Point_Type
(Ftyp
) then
8794 Def
:= Make_Floating_Point_Definition
(Loc
,
8795 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8796 Make_Real_Range_Specification
(Loc
,
8797 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8798 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8800 -- Should never have a predefined type we cannot handle
8803 raise Program_Error
;
8806 -- Build and insert a Full_Type_Declaration, which will be
8807 -- analyzed as soon as this list entry has been analyzed.
8809 Decl
:= Make_Full_Type_Declaration
(Loc
,
8810 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8811 Type_Definition
=> Def
);
8813 Insert_After
(N
, Decl
);
8814 Mark_Rewrite_Insertion
(Decl
);
8817 Error_Pragma_Arg
("no matching type found for pragma%",
8820 end Process_Import_Predefined_Type
;
8822 ---------------------------------
8823 -- Process_Import_Or_Interface --
8824 ---------------------------------
8826 procedure Process_Import_Or_Interface
is
8832 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8833 -- pragma Import (Entity, "external name");
8835 if Relaxed_RM_Semantics
8836 and then Arg_Count
= 2
8837 and then Prag_Id
= Pragma_Import
8838 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8841 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8844 if not Is_Entity_Name
(Def_Id
) then
8845 Error_Pragma_Arg
("entity name required", Arg1
);
8848 Def_Id
:= Entity
(Def_Id
);
8849 Kill_Size_Check_Code
(Def_Id
);
8850 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8853 Process_Convention
(C
, Def_Id
);
8855 -- A pragma that applies to a Ghost entity becomes Ghost for the
8856 -- purposes of legality checks and removal of ignored Ghost code.
8858 Mark_Ghost_Pragma
(N
, Def_Id
);
8859 Kill_Size_Check_Code
(Def_Id
);
8860 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8863 -- Various error checks
8865 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8867 -- We do not permit Import to apply to a renaming declaration
8869 if Present
(Renamed_Object
(Def_Id
)) then
8871 ("pragma% not allowed for object renaming", Arg2
);
8873 -- User initialization is not allowed for imported object, but
8874 -- the object declaration may contain a default initialization,
8875 -- that will be discarded. Note that an explicit initialization
8876 -- only counts if it comes from source, otherwise it is simply
8877 -- the code generator making an implicit initialization explicit.
8879 elsif Present
(Expression
(Parent
(Def_Id
)))
8880 and then Comes_From_Source
8881 (Original_Node
(Expression
(Parent
(Def_Id
))))
8883 -- Set imported flag to prevent cascaded errors
8885 Set_Is_Imported
(Def_Id
);
8887 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8889 ("no initialization allowed for declaration of& #",
8890 "\imported entities cannot be initialized (RM B.1(24))",
8894 -- If the pragma comes from an aspect specification the
8895 -- Is_Imported flag has already been set.
8897 if not From_Aspect_Specification
(N
) then
8898 Set_Imported
(Def_Id
);
8901 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8903 -- Note that we do not set Is_Public here. That's because we
8904 -- only want to set it if there is no address clause, and we
8905 -- don't know that yet, so we delay that processing till
8908 -- pragma Import completes deferred constants
8910 if Ekind
(Def_Id
) = E_Constant
then
8911 Set_Has_Completion
(Def_Id
);
8914 -- It is not possible to import a constant of an unconstrained
8915 -- array type (e.g. string) because there is no simple way to
8916 -- write a meaningful subtype for it.
8918 if Is_Array_Type
(Etype
(Def_Id
))
8919 and then not Is_Constrained
(Etype
(Def_Id
))
8922 ("imported constant& must have a constrained subtype",
8927 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8929 -- If the name is overloaded, pragma applies to all of the denoted
8930 -- entities in the same declarative part, unless the pragma comes
8931 -- from an aspect specification or was generated by the compiler
8932 -- (such as for pragma Provide_Shift_Operators).
8935 while Present
(Hom_Id
) loop
8937 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8939 -- Ignore inherited subprograms because the pragma will apply
8940 -- to the parent operation, which is the one called.
8942 if Is_Overloadable
(Def_Id
)
8943 and then Present
(Alias
(Def_Id
))
8947 -- If it is not a subprogram, it must be in an outer scope and
8948 -- pragma does not apply.
8950 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8953 -- The pragma does not apply to primitives of interfaces
8955 elsif Is_Dispatching_Operation
(Def_Id
)
8956 and then Present
(Find_Dispatching_Type
(Def_Id
))
8957 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8961 -- Verify that the homonym is in the same declarative part (not
8962 -- just the same scope). If the pragma comes from an aspect
8963 -- specification we know that it is part of the declaration.
8965 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8966 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8967 and then not From_Aspect_Specification
(N
)
8972 -- If the pragma comes from an aspect specification the
8973 -- Is_Imported flag has already been set.
8975 if not From_Aspect_Specification
(N
) then
8976 Set_Imported
(Def_Id
);
8979 -- Reject an Import applied to an abstract subprogram
8981 if Is_Subprogram
(Def_Id
)
8982 and then Is_Abstract_Subprogram
(Def_Id
)
8984 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8986 ("cannot import abstract subprogram& declared#",
8990 -- Special processing for Convention_Intrinsic
8992 if C
= Convention_Intrinsic
then
8994 -- Link_Name argument not allowed for intrinsic
8998 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9000 -- If no external name is present, then check that this
9001 -- is a valid intrinsic subprogram. If an external name
9002 -- is present, then this is handled by the back end.
9005 Check_Intrinsic_Subprogram
9006 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9010 -- Verify that the subprogram does not have a completion
9011 -- through a renaming declaration. For other completions the
9012 -- pragma appears as a too late representation.
9015 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9019 and then Nkind
(Decl
) = N_Subprogram_Declaration
9020 and then Present
(Corresponding_Body
(Decl
))
9021 and then Nkind
(Unit_Declaration_Node
9022 (Corresponding_Body
(Decl
))) =
9023 N_Subprogram_Renaming_Declaration
9025 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9027 ("cannot import&, renaming already provided for "
9028 & "declaration #", N
, Def_Id
);
9032 -- If the pragma comes from an aspect specification, there
9033 -- must be an Import aspect specified as well. In the rare
9034 -- case where Import is set to False, the suprogram needs to
9035 -- have a local completion.
9038 Imp_Aspect
: constant Node_Id
:=
9039 Find_Aspect
(Def_Id
, Aspect_Import
);
9043 if Present
(Imp_Aspect
)
9044 and then Present
(Expression
(Imp_Aspect
))
9046 Expr
:= Expression
(Imp_Aspect
);
9047 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9049 if Is_Entity_Name
(Expr
)
9050 and then Entity
(Expr
) = Standard_True
9052 Set_Has_Completion
(Def_Id
);
9055 -- If there is no expression, the default is True, as for
9056 -- all boolean aspects. Same for the older pragma.
9059 Set_Has_Completion
(Def_Id
);
9063 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9066 if Is_Compilation_Unit
(Hom_Id
) then
9068 -- Its possible homonyms are not affected by the pragma.
9069 -- Such homonyms might be present in the context of other
9070 -- units being compiled.
9074 elsif From_Aspect_Specification
(N
) then
9077 -- If the pragma was created by the compiler, then we don't
9078 -- want it to apply to other homonyms. This kind of case can
9079 -- occur when using pragma Provide_Shift_Operators, which
9080 -- generates implicit shift and rotate operators with Import
9081 -- pragmas that might apply to earlier explicit or implicit
9082 -- declarations marked with Import (for example, coming from
9083 -- an earlier pragma Provide_Shift_Operators for another type),
9084 -- and we don't generally want other homonyms being treated
9085 -- as imported or the pragma flagged as an illegal duplicate.
9087 elsif not Comes_From_Source
(N
) then
9091 Hom_Id
:= Homonym
(Hom_Id
);
9095 -- Import a CPP class
9097 elsif C
= Convention_CPP
9098 and then (Is_Record_Type
(Def_Id
)
9099 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9101 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9102 if Present
(Full_View
(Def_Id
)) then
9103 Def_Id
:= Full_View
(Def_Id
);
9107 ("cannot import 'C'P'P type before full declaration seen",
9108 Get_Pragma_Arg
(Arg2
));
9110 -- Although we have reported the error we decorate it as
9111 -- CPP_Class to avoid reporting spurious errors
9113 Set_Is_CPP_Class
(Def_Id
);
9118 -- Types treated as CPP classes must be declared limited (note:
9119 -- this used to be a warning but there is no real benefit to it
9120 -- since we did effectively intend to treat the type as limited
9123 if not Is_Limited_Type
(Def_Id
) then
9125 ("imported 'C'P'P type must be limited",
9126 Get_Pragma_Arg
(Arg2
));
9129 if Etype
(Def_Id
) /= Def_Id
9130 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9132 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9135 Set_Is_CPP_Class
(Def_Id
);
9137 -- Imported CPP types must not have discriminants (because C++
9138 -- classes do not have discriminants).
9140 if Has_Discriminants
(Def_Id
) then
9142 ("imported 'C'P'P type cannot have discriminants",
9143 First
(Discriminant_Specifications
9144 (Declaration_Node
(Def_Id
))));
9147 -- Check that components of imported CPP types do not have default
9148 -- expressions. For private types this check is performed when the
9149 -- full view is analyzed (see Process_Full_View).
9151 if not Is_Private_Type
(Def_Id
) then
9152 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9155 -- Import a CPP exception
9157 elsif C
= Convention_CPP
9158 and then Ekind
(Def_Id
) = E_Exception
9162 ("'External_'Name arguments is required for 'Cpp exception",
9165 -- As only a string is allowed, Check_Arg_Is_External_Name
9168 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9171 if Present
(Arg4
) then
9173 ("Link_Name argument not allowed for imported Cpp exception",
9177 -- Do not call Set_Interface_Name as the name of the exception
9178 -- shouldn't be modified (and in particular it shouldn't be
9179 -- the External_Name). For exceptions, the External_Name is the
9180 -- name of the RTTI structure.
9182 -- ??? Emit an error if pragma Import/Export_Exception is present
9184 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9186 Check_Arg_Count
(3);
9187 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9189 Process_Import_Predefined_Type
;
9193 ("second argument of pragma% must be object, subprogram "
9194 & "or incomplete type",
9198 -- If this pragma applies to a compilation unit, then the unit, which
9199 -- is a subprogram, does not require (or allow) a body. We also do
9200 -- not need to elaborate imported procedures.
9202 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9204 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9206 Set_Body_Required
(Cunit
, False);
9209 end Process_Import_Or_Interface
;
9211 --------------------
9212 -- Process_Inline --
9213 --------------------
9215 procedure Process_Inline
(Status
: Inline_Status
) is
9222 Ghost_Error_Posted
: Boolean := False;
9223 -- Flag set when an error concerning the illegal mix of Ghost and
9224 -- non-Ghost subprograms is emitted.
9226 Ghost_Id
: Entity_Id
:= Empty
;
9227 -- The entity of the first Ghost subprogram encountered while
9228 -- processing the arguments of the pragma.
9230 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9231 -- Verify the placement of pragma Inline_Always with respect to the
9232 -- initial declaration of subprogram Spec_Id.
9234 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9235 -- Returns True if it can be determined at this stage that inlining
9236 -- is not possible, for example if the body is available and contains
9237 -- exception handlers, we prevent inlining, since otherwise we can
9238 -- get undefined symbols at link time. This function also emits a
9239 -- warning if the pragma appears too late.
9241 -- ??? is business with link symbols still valid, or does it relate
9242 -- to front end ZCX which is being phased out ???
9244 procedure Make_Inline
(Subp
: Entity_Id
);
9245 -- Subp is the defining unit name of the subprogram declaration. If
9246 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9247 -- the corresponding body, if there is one present.
9249 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9250 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9251 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9253 -----------------------------------
9254 -- Check_Inline_Always_Placement --
9255 -----------------------------------
9257 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9258 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9260 function Compilation_Unit_OK
return Boolean;
9261 pragma Inline
(Compilation_Unit_OK
);
9262 -- Determine whether pragma Inline_Always applies to a compatible
9263 -- compilation unit denoted by Spec_Id.
9265 function Declarative_List_OK
return Boolean;
9266 pragma Inline
(Declarative_List_OK
);
9267 -- Determine whether the initial declaration of subprogram Spec_Id
9268 -- and the pragma appear in compatible declarative lists.
9270 function Subprogram_Body_OK
return Boolean;
9271 pragma Inline
(Subprogram_Body_OK
);
9272 -- Determine whether pragma Inline_Always applies to a compatible
9273 -- subprogram body denoted by Spec_Id.
9275 -------------------------
9276 -- Compilation_Unit_OK --
9277 -------------------------
9279 function Compilation_Unit_OK
return Boolean is
9280 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9283 -- The pragma appears after the initial declaration of a
9284 -- compilation unit.
9286 -- procedure Comp_Unit;
9287 -- pragma Inline_Always (Comp_Unit);
9289 -- Note that for compatibility reasons, the following case is
9292 -- procedure Stand_Alone_Body_Comp_Unit is
9294 -- end Stand_Alone_Body_Comp_Unit;
9295 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9298 Nkind
(Comp_Unit
) = N_Compilation_Unit
9299 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9300 and then Is_List_Member
(N
)
9301 and then List_Containing
(N
) =
9302 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9303 end Compilation_Unit_OK
;
9305 -------------------------
9306 -- Declarative_List_OK --
9307 -------------------------
9309 function Declarative_List_OK
return Boolean is
9310 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9312 Init_Decl
: Node_Id
;
9313 Init_List
: List_Id
;
9314 Prag_List
: List_Id
;
9317 -- Determine the proper initial declaration. In general this is
9318 -- the declaration node of the subprogram except when the input
9319 -- denotes a generic instantiation.
9321 -- procedure Inst is new Gen;
9322 -- pragma Inline_Always (Inst);
9324 -- In this case the original subprogram is moved inside an
9325 -- anonymous package while pragma Inline_Always remains at the
9326 -- level of the anonymous package. Use the declaration of the
9327 -- package because it reflects the placement of the original
9330 -- package Anon_Pack is
9331 -- procedure Inst is ... end Inst; -- original
9334 -- procedure Inst renames Anon_Pack.Inst;
9335 -- pragma Inline_Always (Inst);
9337 if Is_Generic_Instance
(Spec_Id
) then
9338 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9339 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9341 Init_Decl
:= Spec_Decl
;
9344 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9345 Init_List
:= List_Containing
(Init_Decl
);
9346 Prag_List
:= List_Containing
(N
);
9348 -- The pragma and then initial declaration appear within the
9349 -- same declarative list.
9351 if Init_List
= Prag_List
then
9354 -- A special case of the above is when both the pragma and
9355 -- the initial declaration appear in different lists of a
9356 -- package spec, protected definition, or a task definition.
9361 -- pragma Inline_Always (Proc);
9364 elsif Nkind_In
(Context
, N_Package_Specification
,
9365 N_Protected_Definition
,
9367 and then Init_List
= Visible_Declarations
(Context
)
9368 and then Prag_List
= Private_Declarations
(Context
)
9375 end Declarative_List_OK
;
9377 ------------------------
9378 -- Subprogram_Body_OK --
9379 ------------------------
9381 function Subprogram_Body_OK
return Boolean is
9382 Body_Decl
: Node_Id
;
9385 -- The pragma appears within the declarative list of a stand-
9386 -- alone subprogram body.
9388 -- procedure Stand_Alone_Body is
9389 -- pragma Inline_Always (Stand_Alone_Body);
9392 -- end Stand_Alone_Body;
9394 -- The compiler creates a dummy spec in this case, however the
9395 -- pragma remains within the declarative list of the body.
9397 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9398 and then not Comes_From_Source
(Spec_Decl
)
9399 and then Present
(Corresponding_Body
(Spec_Decl
))
9402 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9404 if Present
(Declarations
(Body_Decl
))
9405 and then Is_List_Member
(N
)
9406 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9413 end Subprogram_Body_OK
;
9415 -- Start of processing for Check_Inline_Always_Placement
9418 -- This check is relevant only for pragma Inline_Always
9420 if Pname
/= Name_Inline_Always
then
9423 -- Nothing to do when the pragma is internally generated on the
9424 -- assumption that it is properly placed.
9426 elsif not Comes_From_Source
(N
) then
9429 -- Nothing to do for internally generated subprograms that act
9430 -- as accidental homonyms of a source subprogram being inlined.
9432 elsif not Comes_From_Source
(Spec_Id
) then
9435 -- Nothing to do for generic formal subprograms that act as
9436 -- homonyms of another source subprogram being inlined.
9438 elsif Is_Formal_Subprogram
(Spec_Id
) then
9441 elsif Compilation_Unit_OK
9442 or else Declarative_List_OK
9443 or else Subprogram_Body_OK
9448 -- At this point it is known that the pragma applies to or appears
9449 -- within a completing body, a completing stub, or a subunit.
9451 Error_Msg_Name_1
:= Pname
;
9452 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9453 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9456 ("pragma % must appear on initial declaration of subprogram "
9457 & "% defined #", N
);
9458 end Check_Inline_Always_Placement
;
9460 ---------------------------
9461 -- Inlining_Not_Possible --
9462 ---------------------------
9464 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9465 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9469 if Nkind
(Decl
) = N_Subprogram_Body
then
9470 Stats
:= Handled_Statement_Sequence
(Decl
);
9471 return Present
(Exception_Handlers
(Stats
))
9472 or else Present
(At_End_Proc
(Stats
));
9474 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9475 and then Present
(Corresponding_Body
(Decl
))
9477 if Analyzed
(Corresponding_Body
(Decl
)) then
9478 Error_Msg_N
("pragma appears too late, ignored??", N
);
9481 -- If the subprogram is a renaming as body, the body is just a
9482 -- call to the renamed subprogram, and inlining is trivially
9486 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9487 N_Subprogram_Renaming_Declaration
9493 Handled_Statement_Sequence
9494 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9497 Present
(Exception_Handlers
(Stats
))
9498 or else Present
(At_End_Proc
(Stats
));
9502 -- If body is not available, assume the best, the check is
9503 -- performed again when compiling enclosing package bodies.
9507 end Inlining_Not_Possible
;
9513 procedure Make_Inline
(Subp
: Entity_Id
) is
9514 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9515 Inner_Subp
: Entity_Id
:= Subp
;
9518 -- Ignore if bad type, avoid cascaded error
9520 if Etype
(Subp
) = Any_Type
then
9524 -- If inlining is not possible, for now do not treat as an error
9526 elsif Status
/= Suppressed
9527 and then Front_End_Inlining
9528 and then Inlining_Not_Possible
(Subp
)
9533 -- Here we have a candidate for inlining, but we must exclude
9534 -- derived operations. Otherwise we would end up trying to inline
9535 -- a phantom declaration, and the result would be to drag in a
9536 -- body which has no direct inlining associated with it. That
9537 -- would not only be inefficient but would also result in the
9538 -- backend doing cross-unit inlining in cases where it was
9539 -- definitely inappropriate to do so.
9541 -- However, a simple Comes_From_Source test is insufficient, since
9542 -- we do want to allow inlining of generic instances which also do
9543 -- not come from source. We also need to recognize specs generated
9544 -- by the front-end for bodies that carry the pragma. Finally,
9545 -- predefined operators do not come from source but are not
9546 -- inlineable either.
9548 elsif Is_Generic_Instance
(Subp
)
9549 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9553 elsif not Comes_From_Source
(Subp
)
9554 and then Scope
(Subp
) /= Standard_Standard
9560 -- The referenced entity must either be the enclosing entity, or
9561 -- an entity declared within the current open scope.
9563 if Present
(Scope
(Subp
))
9564 and then Scope
(Subp
) /= Current_Scope
9565 and then Subp
/= Current_Scope
9568 ("argument of% must be entity in current scope", Assoc
);
9572 -- Processing for procedure, operator or function. If subprogram
9573 -- is aliased (as for an instance) indicate that the renamed
9574 -- entity (if declared in the same unit) is inlined.
9575 -- If this is the anonymous subprogram created for a subprogram
9576 -- instance, the inlining applies to it directly. Otherwise we
9577 -- retrieve it as the alias of the visible subprogram instance.
9579 if Is_Subprogram
(Subp
) then
9581 -- Ensure that pragma Inline_Always is associated with the
9582 -- initial declaration of the subprogram.
9584 Check_Inline_Always_Placement
(Subp
);
9586 if Is_Wrapper_Package
(Scope
(Subp
)) then
9589 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9592 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9593 Set_Inline_Flags
(Inner_Subp
);
9595 Decl
:= Parent
(Parent
(Inner_Subp
));
9597 if Nkind
(Decl
) = N_Subprogram_Declaration
9598 and then Present
(Corresponding_Body
(Decl
))
9600 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9602 elsif Is_Generic_Instance
(Subp
)
9603 and then Comes_From_Source
(Subp
)
9605 -- Indicate that the body needs to be created for
9606 -- inlining subsequent calls. The instantiation node
9607 -- follows the declaration of the wrapper package
9608 -- created for it. The subprogram that requires the
9609 -- body is the anonymous one in the wrapper package.
9611 if Scope
(Subp
) /= Standard_Standard
9613 Need_Subprogram_Instance_Body
9614 (Next
(Unit_Declaration_Node
9615 (Scope
(Alias
(Subp
)))), Subp
)
9620 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9621 -- appear in a formal part to apply to a formal subprogram.
9622 -- Do not apply check within an instance or a formal package
9623 -- the test will have been applied to the original generic.
9625 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9626 and then List_Containing
(Decl
) = List_Containing
(N
)
9627 and then not In_Instance
9630 ("Inline cannot apply to a formal subprogram", N
);
9632 -- If Subp is a renaming, it is the renamed entity that
9633 -- will appear in any call, and be inlined. However, for
9634 -- ASIS uses it is convenient to indicate that the renaming
9635 -- itself is an inlined subprogram, so that some gnatcheck
9636 -- rules can be applied in the absence of expansion.
9638 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9639 Set_Inline_Flags
(Subp
);
9645 -- For a generic subprogram set flag as well, for use at the point
9646 -- of instantiation, to determine whether the body should be
9649 elsif Is_Generic_Subprogram
(Subp
) then
9650 Set_Inline_Flags
(Subp
);
9653 -- Literals are by definition inlined
9655 elsif Kind
= E_Enumeration_Literal
then
9658 -- Anything else is an error
9662 ("expect subprogram name for pragma%", Assoc
);
9666 ----------------------
9667 -- Set_Inline_Flags --
9668 ----------------------
9670 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9672 -- First set the Has_Pragma_XXX flags and issue the appropriate
9673 -- errors and warnings for suspicious combinations.
9675 if Prag_Id
= Pragma_No_Inline
then
9676 if Has_Pragma_Inline_Always
(Subp
) then
9678 ("Inline_Always and No_Inline are mutually exclusive", N
);
9679 elsif Has_Pragma_Inline
(Subp
) then
9681 ("Inline and No_Inline both specified for& ??",
9682 N
, Entity
(Subp_Id
));
9685 Set_Has_Pragma_No_Inline
(Subp
);
9687 if Prag_Id
= Pragma_Inline_Always
then
9688 if Has_Pragma_No_Inline
(Subp
) then
9690 ("Inline_Always and No_Inline are mutually exclusive",
9694 Set_Has_Pragma_Inline_Always
(Subp
);
9696 if Has_Pragma_No_Inline
(Subp
) then
9698 ("Inline and No_Inline both specified for& ??",
9699 N
, Entity
(Subp_Id
));
9703 Set_Has_Pragma_Inline
(Subp
);
9706 -- Then adjust the Is_Inlined flag. It can never be set if the
9707 -- subprogram is subject to pragma No_Inline.
9711 Set_Is_Inlined
(Subp
, False);
9717 if not Has_Pragma_No_Inline
(Subp
) then
9718 Set_Is_Inlined
(Subp
, True);
9722 -- A pragma that applies to a Ghost entity becomes Ghost for the
9723 -- purposes of legality checks and removal of ignored Ghost code.
9725 Mark_Ghost_Pragma
(N
, Subp
);
9727 -- Capture the entity of the first Ghost subprogram being
9728 -- processed for error detection purposes.
9730 if Is_Ghost_Entity
(Subp
) then
9731 if No
(Ghost_Id
) then
9735 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9736 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9738 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9739 Ghost_Error_Posted
:= True;
9741 Error_Msg_Name_1
:= Pname
;
9743 ("pragma % cannot mention ghost and non-ghost subprograms",
9746 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9747 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9749 Error_Msg_Sloc
:= Sloc
(Subp
);
9750 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9752 end Set_Inline_Flags
;
9754 -- Start of processing for Process_Inline
9757 Check_No_Identifiers
;
9758 Check_At_Least_N_Arguments
(1);
9760 if Status
= Enabled
then
9761 Inline_Processing_Required
:= True;
9765 while Present
(Assoc
) loop
9766 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9770 if Is_Entity_Name
(Subp_Id
) then
9771 Subp
:= Entity
(Subp_Id
);
9773 if Subp
= Any_Id
then
9775 -- If previous error, avoid cascaded errors
9777 Check_Error_Detected
;
9783 -- For the pragma case, climb homonym chain. This is
9784 -- what implements allowing the pragma in the renaming
9785 -- case, with the result applying to the ancestors, and
9786 -- also allows Inline to apply to all previous homonyms.
9788 if not From_Aspect_Specification
(N
) then
9789 while Present
(Homonym
(Subp
))
9790 and then Scope
(Homonym
(Subp
)) = Current_Scope
9792 Make_Inline
(Homonym
(Subp
));
9793 Subp
:= Homonym
(Subp
);
9800 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9806 -- If the context is a package declaration, the pragma indicates
9807 -- that inlining will require the presence of the corresponding
9808 -- body. (this may be further refined).
9811 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9812 N_Package_Declaration
9814 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9818 ----------------------------
9819 -- Process_Interface_Name --
9820 ----------------------------
9822 procedure Process_Interface_Name
9823 (Subprogram_Def
: Entity_Id
;
9830 String_Val
: String_Id
;
9832 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9833 -- SN is a string literal node for an interface name. This routine
9834 -- performs some minimal checks that the name is reasonable. In
9835 -- particular that no spaces or other obviously incorrect characters
9836 -- appear. This is only a warning, since any characters are allowed.
9838 ----------------------------------
9839 -- Check_Form_Of_Interface_Name --
9840 ----------------------------------
9842 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9843 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9844 SL
: constant Nat
:= String_Length
(S
);
9849 Error_Msg_N
("interface name cannot be null string", SN
);
9852 for J
in 1 .. SL
loop
9853 C
:= Get_String_Char
(S
, J
);
9855 -- Look for dubious character and issue unconditional warning.
9856 -- Definitely dubious if not in character range.
9858 if not In_Character_Range
(C
)
9860 -- Commas, spaces and (back)slashes are dubious
9862 or else Get_Character
(C
) = ','
9863 or else Get_Character
(C
) = '\'
9864 or else Get_Character
(C
) = ' '
9865 or else Get_Character
(C
) = '/'
9868 ("??interface name contains illegal character",
9869 Sloc
(SN
) + Source_Ptr
(J
));
9872 end Check_Form_Of_Interface_Name
;
9874 -- Start of processing for Process_Interface_Name
9877 -- If we are looking at a pragma that comes from an aspect then it
9878 -- needs to have its corresponding aspect argument expressions
9879 -- analyzed in addition to the generated pragma so that aspects
9880 -- within generic units get properly resolved.
9882 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9884 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9892 -- Obtain all interfacing aspects used to construct the pragma
9894 Get_Interfacing_Aspects
9895 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9897 -- Analyze the expression of aspect External_Name
9899 if Present
(EN
) then
9900 Analyze
(Expression
(EN
));
9903 -- Analyze the expressio of aspect Link_Name
9905 if Present
(LN
) then
9906 Analyze
(Expression
(LN
));
9911 if No
(Link_Arg
) then
9912 if No
(Ext_Arg
) then
9915 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9917 Link_Nam
:= Expression
(Ext_Arg
);
9920 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9921 Ext_Nam
:= Expression
(Ext_Arg
);
9926 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9927 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9928 Ext_Nam
:= Expression
(Ext_Arg
);
9929 Link_Nam
:= Expression
(Link_Arg
);
9932 -- Check expressions for external name and link name are static
9934 if Present
(Ext_Nam
) then
9935 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9936 Check_Form_Of_Interface_Name
(Ext_Nam
);
9938 -- Verify that external name is not the name of a local entity,
9939 -- which would hide the imported one and could lead to run-time
9940 -- surprises. The problem can only arise for entities declared in
9941 -- a package body (otherwise the external name is fully qualified
9942 -- and will not conflict).
9950 if Prag_Id
= Pragma_Import
then
9951 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9952 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9954 if Nam
/= Chars
(Subprogram_Def
)
9955 and then Present
(E
)
9956 and then not Is_Overloadable
(E
)
9957 and then Is_Immediately_Visible
(E
)
9958 and then not Is_Imported
(E
)
9959 and then Ekind
(Scope
(E
)) = E_Package
9962 while Present
(Par
) loop
9963 if Nkind
(Par
) = N_Package_Body
then
9964 Error_Msg_Sloc
:= Sloc
(E
);
9966 ("imported entity is hidden by & declared#",
9971 Par
:= Parent
(Par
);
9978 if Present
(Link_Nam
) then
9979 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9980 Check_Form_Of_Interface_Name
(Link_Nam
);
9983 -- If there is no link name, just set the external name
9985 if No
(Link_Nam
) then
9986 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9988 -- For the Link_Name case, the given literal is preceded by an
9989 -- asterisk, which indicates to GCC that the given name should be
9990 -- taken literally, and in particular that no prepending of
9991 -- underlines should occur, even in systems where this is the
9996 Store_String_Char
(Get_Char_Code
('*'));
9997 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9998 Store_String_Chars
(String_Val
);
10000 Make_String_Literal
(Sloc
(Link_Nam
),
10001 Strval
=> End_String
);
10004 -- Set the interface name. If the entity is a generic instance, use
10005 -- its alias, which is the callable entity.
10007 if Is_Generic_Instance
(Subprogram_Def
) then
10008 Set_Encoded_Interface_Name
10009 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10011 Set_Encoded_Interface_Name
10012 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10015 Check_Duplicated_Export_Name
(Link_Nam
);
10016 end Process_Interface_Name
;
10018 -----------------------------------------
10019 -- Process_Interrupt_Or_Attach_Handler --
10020 -----------------------------------------
10022 procedure Process_Interrupt_Or_Attach_Handler
is
10023 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10024 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10027 -- A pragma that applies to a Ghost entity becomes Ghost for the
10028 -- purposes of legality checks and removal of ignored Ghost code.
10030 Mark_Ghost_Pragma
(N
, Handler
);
10031 Set_Is_Interrupt_Handler
(Handler
);
10033 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10035 Record_Rep_Item
(Prot_Typ
, N
);
10037 -- Chain the pragma on the contract for completeness
10039 Add_Contract_Item
(N
, Handler
);
10040 end Process_Interrupt_Or_Attach_Handler
;
10042 --------------------------------------------------
10043 -- Process_Restrictions_Or_Restriction_Warnings --
10044 --------------------------------------------------
10046 -- Note: some of the simple identifier cases were handled in par-prag,
10047 -- but it is harmless (and more straightforward) to simply handle all
10048 -- cases here, even if it means we repeat a bit of work in some cases.
10050 procedure Process_Restrictions_Or_Restriction_Warnings
10054 R_Id
: Restriction_Id
;
10060 -- Ignore all Restrictions pragmas in CodePeer mode
10062 if CodePeer_Mode
then
10066 Check_Ada_83_Warning
;
10067 Check_At_Least_N_Arguments
(1);
10068 Check_Valid_Configuration_Pragma
;
10071 while Present
(Arg
) loop
10073 Expr
:= Get_Pragma_Arg
(Arg
);
10075 -- Case of no restriction identifier present
10077 if Id
= No_Name
then
10078 if Nkind
(Expr
) /= N_Identifier
then
10080 ("invalid form for restriction", Arg
);
10085 (Process_Restriction_Synonyms
(Expr
));
10087 if R_Id
not in All_Boolean_Restrictions
then
10088 Error_Msg_Name_1
:= Pname
;
10090 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10092 -- Check for possible misspelling
10094 for J
in Restriction_Id
loop
10096 Rnm
: constant String := Restriction_Id
'Image (J
);
10099 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10100 Name_Len
:= Rnm
'Length;
10101 Set_Casing
(All_Lower_Case
);
10103 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10106 (Source_Index
(Current_Sem_Unit
)));
10107 Error_Msg_String
(1 .. Rnm
'Length) :=
10108 Name_Buffer
(1 .. Name_Len
);
10109 Error_Msg_Strlen
:= Rnm
'Length;
10110 Error_Msg_N
-- CODEFIX
10111 ("\possible misspelling of ""~""",
10112 Get_Pragma_Arg
(Arg
));
10121 if Implementation_Restriction
(R_Id
) then
10122 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10125 -- Special processing for No_Elaboration_Code restriction
10127 if R_Id
= No_Elaboration_Code
then
10129 -- Restriction is only recognized within a configuration
10130 -- pragma file, or within a unit of the main extended
10131 -- program. Note: the test for Main_Unit is needed to
10132 -- properly include the case of configuration pragma files.
10134 if not (Current_Sem_Unit
= Main_Unit
10135 or else In_Extended_Main_Source_Unit
(N
))
10139 -- Don't allow in a subunit unless already specified in
10142 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10143 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10144 and then not Restriction_Active
(No_Elaboration_Code
)
10147 ("invalid specification of ""No_Elaboration_Code""",
10150 ("\restriction cannot be specified in a subunit", N
);
10152 ("\unless also specified in body or spec", N
);
10155 -- If we accept a No_Elaboration_Code restriction, then it
10156 -- needs to be added to the configuration restriction set so
10157 -- that we get proper application to other units in the main
10158 -- extended source as required.
10161 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10165 -- If this is a warning, then set the warning unless we already
10166 -- have a real restriction active (we never want a warning to
10167 -- override a real restriction).
10170 if not Restriction_Active
(R_Id
) then
10171 Set_Restriction
(R_Id
, N
);
10172 Restriction_Warnings
(R_Id
) := True;
10175 -- If real restriction case, then set it and make sure that the
10176 -- restriction warning flag is off, since a real restriction
10177 -- always overrides a warning.
10180 Set_Restriction
(R_Id
, N
);
10181 Restriction_Warnings
(R_Id
) := False;
10184 -- Check for obsolescent restrictions in Ada 2005 mode
10187 and then Ada_Version
>= Ada_2005
10188 and then (R_Id
= No_Asynchronous_Control
10190 R_Id
= No_Unchecked_Deallocation
10192 R_Id
= No_Unchecked_Conversion
)
10194 Check_Restriction
(No_Obsolescent_Features
, N
);
10197 -- A very special case that must be processed here: pragma
10198 -- Restrictions (No_Exceptions) turns off all run-time
10199 -- checking. This is a bit dubious in terms of the formal
10200 -- language definition, but it is what is intended by RM
10201 -- H.4(12). Restriction_Warnings never affects generated code
10202 -- so this is done only in the real restriction case.
10204 -- Atomic_Synchronization is not a real check, so it is not
10205 -- affected by this processing).
10207 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10208 -- run-time checks in CodePeer and GNATprove modes: we want to
10209 -- generate checks for analysis purposes, as set respectively
10210 -- by -gnatC and -gnatd.F
10213 and then not (CodePeer_Mode
or GNATprove_Mode
)
10214 and then R_Id
= No_Exceptions
10216 for J
in Scope_Suppress
.Suppress
'Range loop
10217 if J
/= Atomic_Synchronization
then
10218 Scope_Suppress
.Suppress
(J
) := True;
10223 -- Case of No_Dependence => unit-name. Note that the parser
10224 -- already made the necessary entry in the No_Dependence table.
10226 elsif Id
= Name_No_Dependence
then
10227 if not OK_No_Dependence_Unit_Name
(Expr
) then
10231 -- Case of No_Specification_Of_Aspect => aspect-identifier
10233 elsif Id
= Name_No_Specification_Of_Aspect
then
10238 if Nkind
(Expr
) /= N_Identifier
then
10241 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10244 if A_Id
= No_Aspect
then
10245 Error_Pragma_Arg
("invalid restriction name", Arg
);
10247 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10251 -- Case of No_Use_Of_Attribute => attribute-identifier
10253 elsif Id
= Name_No_Use_Of_Attribute
then
10254 if Nkind
(Expr
) /= N_Identifier
10255 or else not Is_Attribute_Name
(Chars
(Expr
))
10257 Error_Msg_N
("unknown attribute name??", Expr
);
10260 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10263 -- Case of No_Use_Of_Entity => fully-qualified-name
10265 elsif Id
= Name_No_Use_Of_Entity
then
10267 -- Restriction is only recognized within a configuration
10268 -- pragma file, or within a unit of the main extended
10269 -- program. Note: the test for Main_Unit is needed to
10270 -- properly include the case of configuration pragma files.
10272 if Current_Sem_Unit
= Main_Unit
10273 or else In_Extended_Main_Source_Unit
(N
)
10275 if not OK_No_Dependence_Unit_Name
(Expr
) then
10276 Error_Msg_N
("wrong form for entity name", Expr
);
10278 Set_Restriction_No_Use_Of_Entity
10279 (Expr
, Warn
, No_Profile
);
10283 -- Case of No_Use_Of_Pragma => pragma-identifier
10285 elsif Id
= Name_No_Use_Of_Pragma
then
10286 if Nkind
(Expr
) /= N_Identifier
10287 or else not Is_Pragma_Name
(Chars
(Expr
))
10289 Error_Msg_N
("unknown pragma name??", Expr
);
10291 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10294 -- All other cases of restriction identifier present
10297 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10298 Analyze_And_Resolve
(Expr
, Any_Integer
);
10300 if R_Id
not in All_Parameter_Restrictions
then
10302 ("invalid restriction parameter identifier", Arg
);
10304 elsif not Is_OK_Static_Expression
(Expr
) then
10305 Flag_Non_Static_Expr
10306 ("value must be static expression!", Expr
);
10309 elsif not Is_Integer_Type
(Etype
(Expr
))
10310 or else Expr_Value
(Expr
) < 0
10313 ("value must be non-negative integer", Arg
);
10316 -- Restriction pragma is active
10318 Val
:= Expr_Value
(Expr
);
10320 if not UI_Is_In_Int_Range
(Val
) then
10322 ("pragma ignored, value too large??", Arg
);
10325 -- Warning case. If the real restriction is active, then we
10326 -- ignore the request, since warning never overrides a real
10327 -- restriction. Otherwise we set the proper warning. Note that
10328 -- this circuit sets the warning again if it is already set,
10329 -- which is what we want, since the constant may have changed.
10332 if not Restriction_Active
(R_Id
) then
10334 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10335 Restriction_Warnings
(R_Id
) := True;
10338 -- Real restriction case, set restriction and make sure warning
10339 -- flag is off since real restriction always overrides warning.
10342 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10343 Restriction_Warnings
(R_Id
) := False;
10349 end Process_Restrictions_Or_Restriction_Warnings
;
10351 ---------------------------------
10352 -- Process_Suppress_Unsuppress --
10353 ---------------------------------
10355 -- Note: this procedure makes entries in the check suppress data
10356 -- structures managed by Sem. See spec of package Sem for full
10357 -- details on how we handle recording of check suppression.
10359 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10364 In_Package_Spec
: constant Boolean :=
10365 Is_Package_Or_Generic_Package
(Current_Scope
)
10366 and then not In_Package_Body
(Current_Scope
);
10368 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10369 -- Used to suppress a single check on the given entity
10371 --------------------------------
10372 -- Suppress_Unsuppress_Echeck --
10373 --------------------------------
10375 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10377 -- Check for error of trying to set atomic synchronization for
10378 -- a non-atomic variable.
10380 if C
= Atomic_Synchronization
10381 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10384 ("pragma & requires atomic type or variable",
10385 Pragma_Identifier
(Original_Node
(N
)));
10388 Set_Checks_May_Be_Suppressed
(E
);
10390 if In_Package_Spec
then
10391 Push_Global_Suppress_Stack_Entry
10394 Suppress
=> Suppress_Case
);
10396 Push_Local_Suppress_Stack_Entry
10399 Suppress
=> Suppress_Case
);
10402 -- If this is a first subtype, and the base type is distinct,
10403 -- then also set the suppress flags on the base type.
10405 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10406 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10408 end Suppress_Unsuppress_Echeck
;
10410 -- Start of processing for Process_Suppress_Unsuppress
10413 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10414 -- on user code: we want to generate checks for analysis purposes, as
10415 -- set respectively by -gnatC and -gnatd.F
10417 if Comes_From_Source
(N
)
10418 and then (CodePeer_Mode
or GNATprove_Mode
)
10423 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10424 -- declarative part or a package spec (RM 11.5(5)).
10426 if not Is_Configuration_Pragma
then
10427 Check_Is_In_Decl_Part_Or_Package_Spec
;
10430 Check_At_Least_N_Arguments
(1);
10431 Check_At_Most_N_Arguments
(2);
10432 Check_No_Identifier
(Arg1
);
10433 Check_Arg_Is_Identifier
(Arg1
);
10435 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10437 if C
= No_Check_Id
then
10439 ("argument of pragma% is not valid check name", Arg1
);
10442 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10444 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10446 ("Suppress of Elaboration_Check ignored in SPARK??",
10447 "\elaboration checking rules are statically enforced "
10448 & "(SPARK RM 7.7)", Arg1
);
10451 -- One-argument case
10453 if Arg_Count
= 1 then
10455 -- Make an entry in the local scope suppress table. This is the
10456 -- table that directly shows the current value of the scope
10457 -- suppress check for any check id value.
10459 if C
= All_Checks
then
10461 -- For All_Checks, we set all specific predefined checks with
10462 -- the exception of Elaboration_Check, which is handled
10463 -- specially because of not wanting All_Checks to have the
10464 -- effect of deactivating static elaboration order processing.
10465 -- Atomic_Synchronization is also not affected, since this is
10466 -- not a real check.
10468 for J
in Scope_Suppress
.Suppress
'Range loop
10469 if J
/= Elaboration_Check
10471 J
/= Atomic_Synchronization
10473 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10477 -- If not All_Checks, and predefined check, then set appropriate
10478 -- scope entry. Note that we will set Elaboration_Check if this
10479 -- is explicitly specified. Atomic_Synchronization is allowed
10480 -- only if internally generated and entity is atomic.
10482 elsif C
in Predefined_Check_Id
10483 and then (not Comes_From_Source
(N
)
10484 or else C
/= Atomic_Synchronization
)
10486 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10489 -- Also make an entry in the Local_Entity_Suppress table
10491 Push_Local_Suppress_Stack_Entry
10494 Suppress
=> Suppress_Case
);
10496 -- Case of two arguments present, where the check is suppressed for
10497 -- a specified entity (given as the second argument of the pragma)
10500 -- This is obsolescent in Ada 2005 mode
10502 if Ada_Version
>= Ada_2005
then
10503 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10506 Check_Optional_Identifier
(Arg2
, Name_On
);
10507 E_Id
:= Get_Pragma_Arg
(Arg2
);
10510 if not Is_Entity_Name
(E_Id
) then
10512 ("second argument of pragma% must be entity name", Arg2
);
10515 E
:= Entity
(E_Id
);
10521 -- A pragma that applies to a Ghost entity becomes Ghost for the
10522 -- purposes of legality checks and removal of ignored Ghost code.
10524 Mark_Ghost_Pragma
(N
, E
);
10526 -- Enforce RM 11.5(7) which requires that for a pragma that
10527 -- appears within a package spec, the named entity must be
10528 -- within the package spec. We allow the package name itself
10529 -- to be mentioned since that makes sense, although it is not
10530 -- strictly allowed by 11.5(7).
10533 and then E
/= Current_Scope
10534 and then Scope
(E
) /= Current_Scope
10537 ("entity in pragma% is not in package spec (RM 11.5(7))",
10541 -- Loop through homonyms. As noted below, in the case of a package
10542 -- spec, only homonyms within the package spec are considered.
10545 Suppress_Unsuppress_Echeck
(E
, C
);
10547 if Is_Generic_Instance
(E
)
10548 and then Is_Subprogram
(E
)
10549 and then Present
(Alias
(E
))
10551 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10554 -- Move to next homonym if not aspect spec case
10556 exit when From_Aspect_Specification
(N
);
10560 -- If we are within a package specification, the pragma only
10561 -- applies to homonyms in the same scope.
10563 exit when In_Package_Spec
10564 and then Scope
(E
) /= Current_Scope
;
10567 end Process_Suppress_Unsuppress
;
10569 -------------------------------
10570 -- Record_Independence_Check --
10571 -------------------------------
10573 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10574 pragma Unreferenced
(N
, E
);
10576 -- For GCC back ends the validation is done a priori
10577 -- ??? This code is dead, might be useful in the future
10579 -- if not AAMP_On_Target then
10583 -- Independence_Checks.Append ((N, E));
10586 end Record_Independence_Check
;
10592 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10594 if Is_Imported
(E
) then
10596 ("cannot export entity& that was previously imported", Arg
);
10598 elsif Present
(Address_Clause
(E
))
10599 and then not Relaxed_RM_Semantics
10602 ("cannot export entity& that has an address clause", Arg
);
10605 Set_Is_Exported
(E
);
10607 -- Generate a reference for entity explicitly, because the
10608 -- identifier may be overloaded and name resolution will not
10611 Generate_Reference
(E
, Arg
);
10613 -- Deal with exporting non-library level entity
10615 if not Is_Library_Level_Entity
(E
) then
10617 -- Not allowed at all for subprograms
10619 if Is_Subprogram
(E
) then
10620 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10622 -- Otherwise set public and statically allocated
10626 Set_Is_Statically_Allocated
(E
);
10628 -- Warn if the corresponding W flag is set
10630 if Warn_On_Export_Import
10632 -- Only do this for something that was in the source. Not
10633 -- clear if this can be False now (there used for sure to be
10634 -- cases on some systems where it was False), but anyway the
10635 -- test is harmless if not needed, so it is retained.
10637 and then Comes_From_Source
(Arg
)
10640 ("?x?& has been made static as a result of Export",
10643 ("\?x?this usage is non-standard and non-portable",
10649 if Warn_On_Export_Import
and then Is_Type
(E
) then
10650 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10653 if Warn_On_Export_Import
and Inside_A_Generic
then
10655 ("all instances of& will have the same external name?x?",
10660 ----------------------------------------------
10661 -- Set_Extended_Import_Export_External_Name --
10662 ----------------------------------------------
10664 procedure Set_Extended_Import_Export_External_Name
10665 (Internal_Ent
: Entity_Id
;
10666 Arg_External
: Node_Id
)
10668 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10669 New_Name
: Node_Id
;
10672 if No
(Arg_External
) then
10676 Check_Arg_Is_External_Name
(Arg_External
);
10678 if Nkind
(Arg_External
) = N_String_Literal
then
10679 if String_Length
(Strval
(Arg_External
)) = 0 then
10682 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10685 elsif Nkind
(Arg_External
) = N_Identifier
then
10686 New_Name
:= Get_Default_External_Name
(Arg_External
);
10688 -- Check_Arg_Is_External_Name should let through only identifiers and
10689 -- string literals or static string expressions (which are folded to
10690 -- string literals).
10693 raise Program_Error
;
10696 -- If we already have an external name set (by a prior normal Import
10697 -- or Export pragma), then the external names must match
10699 if Present
(Interface_Name
(Internal_Ent
)) then
10701 -- Ignore mismatching names in CodePeer mode, to support some
10702 -- old compilers which would export the same procedure under
10703 -- different names, e.g:
10705 -- pragma Export_Procedure (P, "a");
10706 -- pragma Export_Procedure (P, "b");
10708 if CodePeer_Mode
then
10712 Check_Matching_Internal_Names
: declare
10713 S1
: constant String_Id
:= Strval
(Old_Name
);
10714 S2
: constant String_Id
:= Strval
(New_Name
);
10716 procedure Mismatch
;
10717 pragma No_Return
(Mismatch
);
10718 -- Called if names do not match
10724 procedure Mismatch
is
10726 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10728 ("external name does not match that given #",
10732 -- Start of processing for Check_Matching_Internal_Names
10735 if String_Length
(S1
) /= String_Length
(S2
) then
10739 for J
in 1 .. String_Length
(S1
) loop
10740 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10745 end Check_Matching_Internal_Names
;
10747 -- Otherwise set the given name
10750 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10751 Check_Duplicated_Export_Name
(New_Name
);
10753 end Set_Extended_Import_Export_External_Name
;
10759 procedure Set_Imported
(E
: Entity_Id
) is
10761 -- Error message if already imported or exported
10763 if Is_Exported
(E
) or else Is_Imported
(E
) then
10765 -- Error if being set Exported twice
10767 if Is_Exported
(E
) then
10768 Error_Msg_NE
("entity& was previously exported", N
, E
);
10770 -- Ignore error in CodePeer mode where we treat all imported
10771 -- subprograms as unknown.
10773 elsif CodePeer_Mode
then
10776 -- OK if Import/Interface case
10778 elsif Import_Interface_Present
(N
) then
10781 -- Error if being set Imported twice
10784 Error_Msg_NE
("entity& was previously imported", N
, E
);
10787 Error_Msg_Name_1
:= Pname
;
10789 ("\(pragma% applies to all previous entities)", N
);
10791 Error_Msg_Sloc
:= Sloc
(E
);
10792 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10794 -- Here if not previously imported or exported, OK to import
10797 Set_Is_Imported
(E
);
10799 -- For subprogram, set Import_Pragma field
10801 if Is_Subprogram
(E
) then
10802 Set_Import_Pragma
(E
, N
);
10805 -- If the entity is an object that is not at the library level,
10806 -- then it is statically allocated. We do not worry about objects
10807 -- with address clauses in this context since they are not really
10808 -- imported in the linker sense.
10811 and then not Is_Library_Level_Entity
(E
)
10812 and then No
(Address_Clause
(E
))
10814 Set_Is_Statically_Allocated
(E
);
10821 -------------------------
10822 -- Set_Mechanism_Value --
10823 -------------------------
10825 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10826 -- analyzed, since it is semantic nonsense), so we get it in the exact
10827 -- form created by the parser.
10829 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10830 procedure Bad_Mechanism
;
10831 pragma No_Return
(Bad_Mechanism
);
10832 -- Signal bad mechanism name
10834 -------------------
10835 -- Bad_Mechanism --
10836 -------------------
10838 procedure Bad_Mechanism
is
10840 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10843 -- Start of processing for Set_Mechanism_Value
10846 if Mechanism
(Ent
) /= Default_Mechanism
then
10848 ("mechanism for & has already been set", Mech_Name
, Ent
);
10851 -- MECHANISM_NAME ::= value | reference
10853 if Nkind
(Mech_Name
) = N_Identifier
then
10854 if Chars
(Mech_Name
) = Name_Value
then
10855 Set_Mechanism
(Ent
, By_Copy
);
10858 elsif Chars
(Mech_Name
) = Name_Reference
then
10859 Set_Mechanism
(Ent
, By_Reference
);
10862 elsif Chars
(Mech_Name
) = Name_Copy
then
10864 ("bad mechanism name, Value assumed", Mech_Name
);
10873 end Set_Mechanism_Value
;
10875 --------------------------
10876 -- Set_Rational_Profile --
10877 --------------------------
10879 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10880 -- extension to the semantics of renaming declarations.
10882 procedure Set_Rational_Profile
is
10884 Implicit_Packing
:= True;
10885 Overriding_Renamings
:= True;
10886 Use_VADS_Size
:= True;
10887 end Set_Rational_Profile
;
10889 ---------------------------
10890 -- Set_Ravenscar_Profile --
10891 ---------------------------
10893 -- The tasks to be done here are
10895 -- Set required policies
10897 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10898 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10899 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10900 -- (For GNAT_Ravenscar_EDF profile)
10901 -- pragma Locking_Policy (Ceiling_Locking)
10903 -- Set Detect_Blocking mode
10905 -- Set required restrictions (see System.Rident for detailed list)
10907 -- Set the No_Dependence rules
10908 -- No_Dependence => Ada.Asynchronous_Task_Control
10909 -- No_Dependence => Ada.Calendar
10910 -- No_Dependence => Ada.Execution_Time.Group_Budget
10911 -- No_Dependence => Ada.Execution_Time.Timers
10912 -- No_Dependence => Ada.Task_Attributes
10913 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10915 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10916 procedure Set_Error_Msg_To_Profile_Name
;
10917 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10920 -----------------------------------
10921 -- Set_Error_Msg_To_Profile_Name --
10922 -----------------------------------
10924 procedure Set_Error_Msg_To_Profile_Name
is
10925 Prof_Nam
: constant Node_Id
:=
10927 (First
(Pragma_Argument_Associations
(N
)));
10930 Get_Name_String
(Chars
(Prof_Nam
));
10931 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10932 Error_Msg_Strlen
:= Name_Len
;
10933 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10934 end Set_Error_Msg_To_Profile_Name
;
10943 Profile_Dispatching_Policy
: Character;
10945 -- Start of processing for Set_Ravenscar_Profile
10948 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10950 if Profile
= GNAT_Ravenscar_EDF
then
10951 Profile_Dispatching_Policy
:= 'E';
10953 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10956 Profile_Dispatching_Policy
:= 'F';
10959 if Task_Dispatching_Policy
/= ' '
10960 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10962 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10963 Set_Error_Msg_To_Profile_Name
;
10964 Error_Pragma
("Profile (~) incompatible with policy#");
10966 -- Set the FIFO_Within_Priorities policy, but always preserve
10967 -- System_Location since we like the error message with the run time
10971 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10973 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10974 Task_Dispatching_Policy_Sloc
:= Loc
;
10978 -- pragma Locking_Policy (Ceiling_Locking)
10980 if Locking_Policy
/= ' '
10981 and then Locking_Policy
/= 'C'
10983 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10984 Set_Error_Msg_To_Profile_Name
;
10985 Error_Pragma
("Profile (~) incompatible with policy#");
10987 -- Set the Ceiling_Locking policy, but preserve System_Location since
10988 -- we like the error message with the run time name.
10991 Locking_Policy
:= 'C';
10993 if Locking_Policy_Sloc
/= System_Location
then
10994 Locking_Policy_Sloc
:= Loc
;
10998 -- pragma Detect_Blocking
11000 Detect_Blocking
:= True;
11002 -- Set the corresponding restrictions
11004 Set_Profile_Restrictions
11005 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11007 -- Set the No_Dependence restrictions
11009 -- The following No_Dependence restrictions:
11010 -- No_Dependence => Ada.Asynchronous_Task_Control
11011 -- No_Dependence => Ada.Calendar
11012 -- No_Dependence => Ada.Task_Attributes
11013 -- are already set by previous call to Set_Profile_Restrictions.
11015 -- Set the following restrictions which were added to Ada 2005:
11016 -- No_Dependence => Ada.Execution_Time.Group_Budget
11017 -- No_Dependence => Ada.Execution_Time.Timers
11019 if Ada_Version
>= Ada_2005
then
11020 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
11021 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
11024 Make_Selected_Component
11027 Selector_Name
=> Sel_Id
);
11029 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
11032 Make_Selected_Component
11035 Selector_Name
=> Sel_Id
);
11037 Set_Restriction_No_Dependence
11039 Warn
=> Treat_Restrictions_As_Warnings
,
11040 Profile
=> Ravenscar
);
11042 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
11045 Make_Selected_Component
11048 Selector_Name
=> Sel_Id
);
11050 Set_Restriction_No_Dependence
11052 Warn
=> Treat_Restrictions_As_Warnings
,
11053 Profile
=> Ravenscar
);
11056 -- Set the following restriction which was added to Ada 2012 (see
11058 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11060 if Ada_Version
>= Ada_2012
then
11061 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
11062 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
11065 Make_Selected_Component
11068 Selector_Name
=> Sel_Id
);
11070 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
11073 Make_Selected_Component
11076 Selector_Name
=> Sel_Id
);
11078 Set_Restriction_No_Dependence
11080 Warn
=> Treat_Restrictions_As_Warnings
,
11081 Profile
=> Ravenscar
);
11083 end Set_Ravenscar_Profile
;
11085 -- Start of processing for Analyze_Pragma
11088 -- The following code is a defense against recursion. Not clear that
11089 -- this can happen legitimately, but perhaps some error situations can
11090 -- cause it, and we did see this recursion during testing.
11092 if Analyzed
(N
) then
11098 Check_Restriction_No_Use_Of_Pragma
(N
);
11100 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11101 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11103 if Should_Ignore_Pragma_Sem
(N
)
11104 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11105 and then Ignore_Rep_Clauses
)
11110 -- Deal with unrecognized pragma
11112 if not Is_Pragma_Name
(Pname
) then
11113 if Warn_On_Unrecognized_Pragma
then
11114 Error_Msg_Name_1
:= Pname
;
11115 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11117 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11118 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11119 Error_Msg_Name_1
:= PN
;
11120 Error_Msg_N
-- CODEFIX
11121 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11130 -- Here to start processing for recognized pragma
11132 Pname
:= Original_Aspect_Pragma_Name
(N
);
11134 -- Capture setting of Opt.Uneval_Old
11136 case Opt
.Uneval_Old
is
11138 Set_Uneval_Old_Accept
(N
);
11144 Set_Uneval_Old_Warn
(N
);
11147 raise Program_Error
;
11150 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11151 -- is already set, indicating that we have already checked the policy
11152 -- at the right point. This happens for example in the case of a pragma
11153 -- that is derived from an Aspect.
11155 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11158 -- For a pragma that is a rewriting of another pragma, copy the
11159 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11161 elsif Is_Rewrite_Substitution
(N
)
11162 and then Nkind
(Original_Node
(N
)) = N_Pragma
11164 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11165 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11167 -- Otherwise query the applicable policy at this point
11170 Check_Applicable_Policy
(N
);
11172 -- If pragma is disabled, rewrite as NULL and skip analysis
11174 if Is_Disabled
(N
) then
11175 Rewrite
(N
, Make_Null_Statement
(Loc
));
11181 -- Preset arguments
11189 if Present
(Pragma_Argument_Associations
(N
)) then
11190 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11191 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11193 if Present
(Arg1
) then
11194 Arg2
:= Next
(Arg1
);
11196 if Present
(Arg2
) then
11197 Arg3
:= Next
(Arg2
);
11199 if Present
(Arg3
) then
11200 Arg4
:= Next
(Arg3
);
11206 -- An enumeration type defines the pragmas that are supported by the
11207 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11208 -- into the corresponding enumeration value for the following case.
11216 -- pragma Abort_Defer;
11218 when Pragma_Abort_Defer
=>
11220 Check_Arg_Count
(0);
11222 -- The only required semantic processing is to check the
11223 -- placement. This pragma must appear at the start of the
11224 -- statement sequence of a handled sequence of statements.
11226 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11227 or else N
/= First
(Statements
(Parent
(N
)))
11232 --------------------
11233 -- Abstract_State --
11234 --------------------
11236 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11238 -- ABSTRACT_STATE_LIST ::=
11240 -- | STATE_NAME_WITH_OPTIONS
11241 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11243 -- STATE_NAME_WITH_OPTIONS ::=
11245 -- | (STATE_NAME with OPTION_LIST)
11247 -- OPTION_LIST ::= OPTION {, OPTION}
11251 -- | NAME_VALUE_OPTION
11253 -- SIMPLE_OPTION ::= Ghost | Synchronous
11255 -- NAME_VALUE_OPTION ::=
11256 -- Part_Of => ABSTRACT_STATE
11257 -- | External [=> EXTERNAL_PROPERTY_LIST]
11259 -- EXTERNAL_PROPERTY_LIST ::=
11260 -- EXTERNAL_PROPERTY
11261 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11263 -- EXTERNAL_PROPERTY ::=
11264 -- Async_Readers [=> boolean_EXPRESSION]
11265 -- | Async_Writers [=> boolean_EXPRESSION]
11266 -- | Effective_Reads [=> boolean_EXPRESSION]
11267 -- | Effective_Writes [=> boolean_EXPRESSION]
11268 -- others => boolean_EXPRESSION
11270 -- STATE_NAME ::= defining_identifier
11272 -- ABSTRACT_STATE ::= name
11274 -- Characteristics:
11276 -- * Analysis - The annotation is fully analyzed immediately upon
11277 -- elaboration as it cannot forward reference entities.
11279 -- * Expansion - None.
11281 -- * Template - The annotation utilizes the generic template of the
11282 -- related package declaration.
11284 -- * Globals - The annotation cannot reference global entities.
11286 -- * Instance - The annotation is instantiated automatically when
11287 -- the related generic package is instantiated.
11289 when Pragma_Abstract_State
=> Abstract_State
: declare
11290 Missing_Parentheses
: Boolean := False;
11291 -- Flag set when a state declaration with options is not properly
11294 -- Flags used to verify the consistency of states
11296 Non_Null_Seen
: Boolean := False;
11297 Null_Seen
: Boolean := False;
11299 procedure Analyze_Abstract_State
11301 Pack_Id
: Entity_Id
);
11302 -- Verify the legality of a single state declaration. Create and
11303 -- decorate a state abstraction entity and introduce it into the
11304 -- visibility chain. Pack_Id denotes the entity or the related
11305 -- package where pragma Abstract_State appears.
11307 procedure Malformed_State_Error
(State
: Node_Id
);
11308 -- Emit an error concerning the illegal declaration of abstract
11309 -- state State. This routine diagnoses syntax errors that lead to
11310 -- a different parse tree. The error is issued regardless of the
11311 -- SPARK mode in effect.
11313 ----------------------------
11314 -- Analyze_Abstract_State --
11315 ----------------------------
11317 procedure Analyze_Abstract_State
11319 Pack_Id
: Entity_Id
)
11321 -- Flags used to verify the consistency of options
11323 AR_Seen
: Boolean := False;
11324 AW_Seen
: Boolean := False;
11325 ER_Seen
: Boolean := False;
11326 EW_Seen
: Boolean := False;
11327 External_Seen
: Boolean := False;
11328 Ghost_Seen
: Boolean := False;
11329 Others_Seen
: Boolean := False;
11330 Part_Of_Seen
: Boolean := False;
11331 Synchronous_Seen
: Boolean := False;
11333 -- Flags used to store the static value of all external states'
11336 AR_Val
: Boolean := False;
11337 AW_Val
: Boolean := False;
11338 ER_Val
: Boolean := False;
11339 EW_Val
: Boolean := False;
11341 State_Id
: Entity_Id
:= Empty
;
11342 -- The entity to be generated for the current state declaration
11344 procedure Analyze_External_Option
(Opt
: Node_Id
);
11345 -- Verify the legality of option External
11347 procedure Analyze_External_Property
11349 Expr
: Node_Id
:= Empty
);
11350 -- Verify the legailty of a single external property. Prop
11351 -- denotes the external property. Expr is the expression used
11352 -- to set the property.
11354 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11355 -- Verify the legality of option Part_Of
11357 procedure Check_Duplicate_Option
11359 Status
: in out Boolean);
11360 -- Flag Status denotes whether a particular option has been
11361 -- seen while processing a state. This routine verifies that
11362 -- Opt is not a duplicate option and sets the flag Status
11363 -- (SPARK RM 7.1.4(1)).
11365 procedure Check_Duplicate_Property
11367 Status
: in out Boolean);
11368 -- Flag Status denotes whether a particular property has been
11369 -- seen while processing option External. This routine verifies
11370 -- that Prop is not a duplicate property and sets flag Status.
11371 -- Opt is not a duplicate property and sets the flag Status.
11372 -- (SPARK RM 7.1.4(2))
11374 procedure Check_Ghost_Synchronous
;
11375 -- Ensure that the abstract state is not subject to both Ghost
11376 -- and Synchronous simple options. Emit an error if this is the
11379 procedure Create_Abstract_State
11383 Is_Null
: Boolean);
11384 -- Generate an abstract state entity with name Nam and enter it
11385 -- into visibility. Decl is the "declaration" of the state as
11386 -- it appears in pragma Abstract_State. Loc is the location of
11387 -- the related state "declaration". Flag Is_Null should be set
11388 -- when the associated Abstract_State pragma defines a null
11391 -----------------------------
11392 -- Analyze_External_Option --
11393 -----------------------------
11395 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11396 Errors
: constant Nat
:= Serious_Errors_Detected
;
11398 Props
: Node_Id
:= Empty
;
11401 if Nkind
(Opt
) = N_Component_Association
then
11402 Props
:= Expression
(Opt
);
11405 -- External state with properties
11407 if Present
(Props
) then
11409 -- Multiple properties appear as an aggregate
11411 if Nkind
(Props
) = N_Aggregate
then
11413 -- Simple property form
11415 Prop
:= First
(Expressions
(Props
));
11416 while Present
(Prop
) loop
11417 Analyze_External_Property
(Prop
);
11421 -- Property with expression form
11423 Prop
:= First
(Component_Associations
(Props
));
11424 while Present
(Prop
) loop
11425 Analyze_External_Property
11426 (Prop
=> First
(Choices
(Prop
)),
11427 Expr
=> Expression
(Prop
));
11435 Analyze_External_Property
(Props
);
11438 -- An external state defined without any properties defaults
11439 -- all properties to True.
11448 -- Once all external properties have been processed, verify
11449 -- their mutual interaction. Do not perform the check when
11450 -- at least one of the properties is illegal as this will
11451 -- produce a bogus error.
11453 if Errors
= Serious_Errors_Detected
then
11454 Check_External_Properties
11455 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11457 end Analyze_External_Option
;
11459 -------------------------------
11460 -- Analyze_External_Property --
11461 -------------------------------
11463 procedure Analyze_External_Property
11465 Expr
: Node_Id
:= Empty
)
11467 Expr_Val
: Boolean;
11470 -- Check the placement of "others" (if available)
11472 if Nkind
(Prop
) = N_Others_Choice
then
11473 if Others_Seen
then
11475 ("only one others choice allowed in option External",
11478 Others_Seen
:= True;
11481 elsif Others_Seen
then
11483 ("others must be the last property in option External",
11486 -- The only remaining legal options are the four predefined
11487 -- external properties.
11489 elsif Nkind
(Prop
) = N_Identifier
11490 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11491 Name_Async_Writers
,
11492 Name_Effective_Reads
,
11493 Name_Effective_Writes
)
11497 -- Otherwise the construct is not a valid property
11500 SPARK_Msg_N
("invalid external state property", Prop
);
11504 -- Ensure that the expression of the external state property
11505 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11507 if Present
(Expr
) then
11508 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11510 if Is_OK_Static_Expression
(Expr
) then
11511 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11514 ("expression of external state property must be "
11519 -- The lack of expression defaults the property to True
11525 -- Named properties
11527 if Nkind
(Prop
) = N_Identifier
then
11528 if Chars
(Prop
) = Name_Async_Readers
then
11529 Check_Duplicate_Property
(Prop
, AR_Seen
);
11530 AR_Val
:= Expr_Val
;
11532 elsif Chars
(Prop
) = Name_Async_Writers
then
11533 Check_Duplicate_Property
(Prop
, AW_Seen
);
11534 AW_Val
:= Expr_Val
;
11536 elsif Chars
(Prop
) = Name_Effective_Reads
then
11537 Check_Duplicate_Property
(Prop
, ER_Seen
);
11538 ER_Val
:= Expr_Val
;
11541 Check_Duplicate_Property
(Prop
, EW_Seen
);
11542 EW_Val
:= Expr_Val
;
11545 -- The handling of property "others" must take into account
11546 -- all other named properties that have been encountered so
11547 -- far. Only those that have not been seen are affected by
11551 if not AR_Seen
then
11552 AR_Val
:= Expr_Val
;
11555 if not AW_Seen
then
11556 AW_Val
:= Expr_Val
;
11559 if not ER_Seen
then
11560 ER_Val
:= Expr_Val
;
11563 if not EW_Seen
then
11564 EW_Val
:= Expr_Val
;
11567 end Analyze_External_Property
;
11569 ----------------------------
11570 -- Analyze_Part_Of_Option --
11571 ----------------------------
11573 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11574 Encap
: constant Node_Id
:= Expression
(Opt
);
11575 Constits
: Elist_Id
;
11576 Encap_Id
: Entity_Id
;
11580 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11583 (Indic
=> First
(Choices
(Opt
)),
11584 Item_Id
=> State_Id
,
11586 Encap_Id
=> Encap_Id
,
11589 -- The Part_Of indicator transforms the abstract state into
11590 -- a constituent of the encapsulating state or single
11591 -- concurrent type.
11594 pragma Assert
(Present
(Encap_Id
));
11595 Constits
:= Part_Of_Constituents
(Encap_Id
);
11597 if No
(Constits
) then
11598 Constits
:= New_Elmt_List
;
11599 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11602 Append_Elmt
(State_Id
, Constits
);
11603 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11605 end Analyze_Part_Of_Option
;
11607 ----------------------------
11608 -- Check_Duplicate_Option --
11609 ----------------------------
11611 procedure Check_Duplicate_Option
11613 Status
: in out Boolean)
11617 SPARK_Msg_N
("duplicate state option", Opt
);
11621 end Check_Duplicate_Option
;
11623 ------------------------------
11624 -- Check_Duplicate_Property --
11625 ------------------------------
11627 procedure Check_Duplicate_Property
11629 Status
: in out Boolean)
11633 SPARK_Msg_N
("duplicate external property", Prop
);
11637 end Check_Duplicate_Property
;
11639 -----------------------------
11640 -- Check_Ghost_Synchronous --
11641 -----------------------------
11643 procedure Check_Ghost_Synchronous
is
11645 -- A synchronized abstract state cannot be Ghost and vice
11646 -- versa (SPARK RM 6.9(19)).
11648 if Ghost_Seen
and Synchronous_Seen
then
11649 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11651 end Check_Ghost_Synchronous
;
11653 ---------------------------
11654 -- Create_Abstract_State --
11655 ---------------------------
11657 procedure Create_Abstract_State
11664 -- The abstract state may be semi-declared when the related
11665 -- package was withed through a limited with clause. In that
11666 -- case reuse the entity to fully declare the state.
11668 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11669 State_Id
:= Entity
(Decl
);
11671 -- Otherwise the elaboration of pragma Abstract_State
11672 -- declares the state.
11675 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11677 if Present
(Decl
) then
11678 Set_Entity
(Decl
, State_Id
);
11682 -- Null states never come from source
11684 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11685 Set_Parent
(State_Id
, State
);
11686 Set_Ekind
(State_Id
, E_Abstract_State
);
11687 Set_Etype
(State_Id
, Standard_Void_Type
);
11688 Set_Encapsulating_State
(State_Id
, Empty
);
11690 -- Set the SPARK mode from the current context
11692 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
11693 Set_SPARK_Pragma_Inherited
(State_Id
);
11695 -- An abstract state declared within a Ghost region becomes
11696 -- Ghost (SPARK RM 6.9(2)).
11698 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11699 Set_Is_Ghost_Entity
(State_Id
);
11702 -- Establish a link between the state declaration and the
11703 -- abstract state entity. Note that a null state remains as
11704 -- N_Null and does not carry any linkages.
11706 if not Is_Null
then
11707 if Present
(Decl
) then
11708 Set_Entity
(Decl
, State_Id
);
11709 Set_Etype
(Decl
, Standard_Void_Type
);
11712 -- Every non-null state must be defined, nameable and
11715 Push_Scope
(Pack_Id
);
11716 Generate_Definition
(State_Id
);
11717 Enter_Name
(State_Id
);
11720 end Create_Abstract_State
;
11727 -- Start of processing for Analyze_Abstract_State
11730 -- A package with a null abstract state is not allowed to
11731 -- declare additional states.
11735 ("package & has null abstract state", State
, Pack_Id
);
11737 -- Null states appear as internally generated entities
11739 elsif Nkind
(State
) = N_Null
then
11740 Create_Abstract_State
11741 (Nam
=> New_Internal_Name
('S'),
11743 Loc
=> Sloc
(State
),
11747 -- Catch a case where a null state appears in a list of
11748 -- non-null states.
11750 if Non_Null_Seen
then
11752 ("package & has non-null abstract state",
11756 -- Simple state declaration
11758 elsif Nkind
(State
) = N_Identifier
then
11759 Create_Abstract_State
11760 (Nam
=> Chars
(State
),
11762 Loc
=> Sloc
(State
),
11764 Non_Null_Seen
:= True;
11766 -- State declaration with various options. This construct
11767 -- appears as an extension aggregate in the tree.
11769 elsif Nkind
(State
) = N_Extension_Aggregate
then
11770 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11771 Create_Abstract_State
11772 (Nam
=> Chars
(Ancestor_Part
(State
)),
11773 Decl
=> Ancestor_Part
(State
),
11774 Loc
=> Sloc
(Ancestor_Part
(State
)),
11776 Non_Null_Seen
:= True;
11779 ("state name must be an identifier",
11780 Ancestor_Part
(State
));
11783 -- Options External, Ghost and Synchronous appear as
11786 Opt
:= First
(Expressions
(State
));
11787 while Present
(Opt
) loop
11788 if Nkind
(Opt
) = N_Identifier
then
11792 if Chars
(Opt
) = Name_External
then
11793 Check_Duplicate_Option
(Opt
, External_Seen
);
11794 Analyze_External_Option
(Opt
);
11798 elsif Chars
(Opt
) = Name_Ghost
then
11799 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11800 Check_Ghost_Synchronous
;
11802 if Present
(State_Id
) then
11803 Set_Is_Ghost_Entity
(State_Id
);
11808 elsif Chars
(Opt
) = Name_Synchronous
then
11809 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11810 Check_Ghost_Synchronous
;
11812 -- Option Part_Of without an encapsulating state is
11813 -- illegal (SPARK RM 7.1.4(9)).
11815 elsif Chars
(Opt
) = Name_Part_Of
then
11817 ("indicator Part_Of must denote abstract state, "
11818 & "single protected type or single task type",
11821 -- Do not emit an error message when a previous state
11822 -- declaration with options was not parenthesized as
11823 -- the option is actually another state declaration.
11825 -- with Abstract_State
11826 -- (State_1 with ..., -- missing parentheses
11827 -- (State_2 with ...),
11828 -- State_3) -- ok state declaration
11830 elsif Missing_Parentheses
then
11833 -- Otherwise the option is not allowed. Note that it
11834 -- is not possible to distinguish between an option
11835 -- and a state declaration when a previous state with
11836 -- options not properly parentheses.
11838 -- with Abstract_State
11839 -- (State_1 with ..., -- missing parentheses
11840 -- State_2); -- could be an option
11844 ("simple option not allowed in state declaration",
11848 -- Catch a case where missing parentheses around a state
11849 -- declaration with options cause a subsequent state
11850 -- declaration with options to be treated as an option.
11852 -- with Abstract_State
11853 -- (State_1 with ..., -- missing parentheses
11854 -- (State_2 with ...))
11856 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11857 Missing_Parentheses
:= True;
11859 ("state declaration must be parenthesized",
11860 Ancestor_Part
(State
));
11862 -- Otherwise the option is malformed
11865 SPARK_Msg_N
("malformed option", Opt
);
11871 -- Options External and Part_Of appear as component
11874 Opt
:= First
(Component_Associations
(State
));
11875 while Present
(Opt
) loop
11876 Opt_Nam
:= First
(Choices
(Opt
));
11878 if Nkind
(Opt_Nam
) = N_Identifier
then
11879 if Chars
(Opt_Nam
) = Name_External
then
11880 Analyze_External_Option
(Opt
);
11882 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11883 Analyze_Part_Of_Option
(Opt
);
11886 SPARK_Msg_N
("invalid state option", Opt
);
11889 SPARK_Msg_N
("invalid state option", Opt
);
11895 -- Any other attempt to declare a state is illegal
11898 Malformed_State_Error
(State
);
11902 -- Guard against a junk state. In such cases no entity is
11903 -- generated and the subsequent checks cannot be applied.
11905 if Present
(State_Id
) then
11907 -- Verify whether the state does not introduce an illegal
11908 -- hidden state within a package subject to a null abstract
11911 Check_No_Hidden_State
(State_Id
);
11913 -- Check whether the lack of option Part_Of agrees with the
11914 -- placement of the abstract state with respect to the state
11917 if not Part_Of_Seen
then
11918 Check_Missing_Part_Of
(State_Id
);
11921 -- Associate the state with its related package
11923 if No
(Abstract_States
(Pack_Id
)) then
11924 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11927 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11929 end Analyze_Abstract_State
;
11931 ---------------------------
11932 -- Malformed_State_Error --
11933 ---------------------------
11935 procedure Malformed_State_Error
(State
: Node_Id
) is
11937 Error_Msg_N
("malformed abstract state declaration", State
);
11939 -- An abstract state with a simple option is being declared
11940 -- with "=>" rather than the legal "with". The state appears
11941 -- as a component association.
11943 if Nkind
(State
) = N_Component_Association
then
11944 Error_Msg_N
("\use WITH to specify simple option", State
);
11946 end Malformed_State_Error
;
11950 Pack_Decl
: Node_Id
;
11951 Pack_Id
: Entity_Id
;
11955 -- Start of processing for Abstract_State
11959 Check_No_Identifiers
;
11960 Check_Arg_Count
(1);
11962 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11964 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11965 N_Package_Declaration
)
11971 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11973 -- A pragma that applies to a Ghost entity becomes Ghost for the
11974 -- purposes of legality checks and removal of ignored Ghost code.
11976 Mark_Ghost_Pragma
(N
, Pack_Id
);
11977 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11979 -- Chain the pragma on the contract for completeness
11981 Add_Contract_Item
(N
, Pack_Id
);
11983 -- The legality checks of pragmas Abstract_State, Initializes, and
11984 -- Initial_Condition are affected by the SPARK mode in effect. In
11985 -- addition, these three pragmas are subject to an inherent order:
11987 -- 1) Abstract_State
11989 -- 3) Initial_Condition
11991 -- Analyze all these pragmas in the order outlined above
11993 Analyze_If_Present
(Pragma_SPARK_Mode
);
11994 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11996 -- Multiple non-null abstract states appear as an aggregate
11998 if Nkind
(States
) = N_Aggregate
then
11999 State
:= First
(Expressions
(States
));
12000 while Present
(State
) loop
12001 Analyze_Abstract_State
(State
, Pack_Id
);
12005 -- An abstract state with a simple option is being illegaly
12006 -- declared with "=>" rather than "with". In this case the
12007 -- state declaration appears as a component association.
12009 if Present
(Component_Associations
(States
)) then
12010 State
:= First
(Component_Associations
(States
));
12011 while Present
(State
) loop
12012 Malformed_State_Error
(State
);
12017 -- Various forms of a single abstract state. Note that these may
12018 -- include malformed state declarations.
12021 Analyze_Abstract_State
(States
, Pack_Id
);
12024 Analyze_If_Present
(Pragma_Initializes
);
12025 Analyze_If_Present
(Pragma_Initial_Condition
);
12026 end Abstract_State
;
12034 -- Note: this pragma also has some specific processing in Par.Prag
12035 -- because we want to set the Ada version mode during parsing.
12037 when Pragma_Ada_83
=>
12039 Check_Arg_Count
(0);
12041 -- We really should check unconditionally for proper configuration
12042 -- pragma placement, since we really don't want mixed Ada modes
12043 -- within a single unit, and the GNAT reference manual has always
12044 -- said this was a configuration pragma, but we did not check and
12045 -- are hesitant to add the check now.
12047 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12048 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12049 -- or Ada 2012 mode.
12051 if Ada_Version
>= Ada_2005
then
12052 Check_Valid_Configuration_Pragma
;
12055 -- Now set Ada 83 mode
12057 if Latest_Ada_Only
then
12058 Error_Pragma
("??pragma% ignored");
12060 Ada_Version
:= Ada_83
;
12061 Ada_Version_Explicit
:= Ada_83
;
12062 Ada_Version_Pragma
:= N
;
12071 -- Note: this pragma also has some specific processing in Par.Prag
12072 -- because we want to set the Ada 83 version mode during parsing.
12074 when Pragma_Ada_95
=>
12076 Check_Arg_Count
(0);
12078 -- We really should check unconditionally for proper configuration
12079 -- pragma placement, since we really don't want mixed Ada modes
12080 -- within a single unit, and the GNAT reference manual has always
12081 -- said this was a configuration pragma, but we did not check and
12082 -- are hesitant to add the check now.
12084 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12085 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12087 if Ada_Version
>= Ada_2005
then
12088 Check_Valid_Configuration_Pragma
;
12091 -- Now set Ada 95 mode
12093 if Latest_Ada_Only
then
12094 Error_Pragma
("??pragma% ignored");
12096 Ada_Version
:= Ada_95
;
12097 Ada_Version_Explicit
:= Ada_95
;
12098 Ada_Version_Pragma
:= N
;
12101 ---------------------
12102 -- Ada_05/Ada_2005 --
12103 ---------------------
12106 -- pragma Ada_05 (LOCAL_NAME);
12108 -- pragma Ada_2005;
12109 -- pragma Ada_2005 (LOCAL_NAME):
12111 -- Note: these pragmas also have some specific processing in Par.Prag
12112 -- because we want to set the Ada 2005 version mode during parsing.
12114 -- The one argument form is used for managing the transition from
12115 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12116 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12117 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12118 -- mode, a preference rule is established which does not choose
12119 -- such an entity unless it is unambiguously specified. This avoids
12120 -- extra subprograms marked this way from generating ambiguities in
12121 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12122 -- intended for exclusive use in the GNAT run-time library.
12133 if Arg_Count
= 1 then
12134 Check_Arg_Is_Local_Name
(Arg1
);
12135 E_Id
:= Get_Pragma_Arg
(Arg1
);
12137 if Etype
(E_Id
) = Any_Type
then
12141 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12142 Record_Rep_Item
(Entity
(E_Id
), N
);
12145 Check_Arg_Count
(0);
12147 -- For Ada_2005 we unconditionally enforce the documented
12148 -- configuration pragma placement, since we do not want to
12149 -- tolerate mixed modes in a unit involving Ada 2005. That
12150 -- would cause real difficulties for those cases where there
12151 -- are incompatibilities between Ada 95 and Ada 2005.
12153 Check_Valid_Configuration_Pragma
;
12155 -- Now set appropriate Ada mode
12157 if Latest_Ada_Only
then
12158 Error_Pragma
("??pragma% ignored");
12160 Ada_Version
:= Ada_2005
;
12161 Ada_Version_Explicit
:= Ada_2005
;
12162 Ada_Version_Pragma
:= N
;
12167 ---------------------
12168 -- Ada_12/Ada_2012 --
12169 ---------------------
12172 -- pragma Ada_12 (LOCAL_NAME);
12174 -- pragma Ada_2012;
12175 -- pragma Ada_2012 (LOCAL_NAME):
12177 -- Note: these pragmas also have some specific processing in Par.Prag
12178 -- because we want to set the Ada 2012 version mode during parsing.
12180 -- The one argument form is used for managing the transition from Ada
12181 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12182 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12183 -- mode will generate a warning. In addition, in any pre-Ada_2012
12184 -- mode, a preference rule is established which does not choose
12185 -- such an entity unless it is unambiguously specified. This avoids
12186 -- extra subprograms marked this way from generating ambiguities in
12187 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12188 -- intended for exclusive use in the GNAT run-time library.
12199 if Arg_Count
= 1 then
12200 Check_Arg_Is_Local_Name
(Arg1
);
12201 E_Id
:= Get_Pragma_Arg
(Arg1
);
12203 if Etype
(E_Id
) = Any_Type
then
12207 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12208 Record_Rep_Item
(Entity
(E_Id
), N
);
12211 Check_Arg_Count
(0);
12213 -- For Ada_2012 we unconditionally enforce the documented
12214 -- configuration pragma placement, since we do not want to
12215 -- tolerate mixed modes in a unit involving Ada 2012. That
12216 -- would cause real difficulties for those cases where there
12217 -- are incompatibilities between Ada 95 and Ada 2012. We could
12218 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12220 Check_Valid_Configuration_Pragma
;
12222 -- Now set appropriate Ada mode
12224 Ada_Version
:= Ada_2012
;
12225 Ada_Version_Explicit
:= Ada_2012
;
12226 Ada_Version_Pragma
:= N
;
12234 -- pragma Ada_2020;
12236 -- Note: this pragma also has some specific processing in Par.Prag
12237 -- because we want to set the Ada 2020 version mode during parsing.
12239 when Pragma_Ada_2020
=>
12242 Check_Arg_Count
(0);
12244 Check_Valid_Configuration_Pragma
;
12246 -- Now set appropriate Ada mode
12248 Ada_Version
:= Ada_2020
;
12249 Ada_Version_Explicit
:= Ada_2020
;
12250 Ada_Version_Pragma
:= N
;
12252 ----------------------
12253 -- All_Calls_Remote --
12254 ----------------------
12256 -- pragma All_Calls_Remote [(library_package_NAME)];
12258 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12259 Lib_Entity
: Entity_Id
;
12262 Check_Ada_83_Warning
;
12263 Check_Valid_Library_Unit_Pragma
;
12265 if Nkind
(N
) = N_Null_Statement
then
12269 Lib_Entity
:= Find_Lib_Unit_Name
;
12271 -- A pragma that applies to a Ghost entity becomes Ghost for the
12272 -- purposes of legality checks and removal of ignored Ghost code.
12274 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12276 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12278 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12279 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12280 Error_Pragma
("pragma% only apply to rci unit");
12282 -- Set flag for entity of the library unit
12285 Set_Has_All_Calls_Remote
(Lib_Entity
);
12288 end All_Calls_Remote
;
12290 ---------------------------
12291 -- Allow_Integer_Address --
12292 ---------------------------
12294 -- pragma Allow_Integer_Address;
12296 when Pragma_Allow_Integer_Address
=>
12298 Check_Valid_Configuration_Pragma
;
12299 Check_Arg_Count
(0);
12301 -- If Address is a private type, then set the flag to allow
12302 -- integer address values. If Address is not private, then this
12303 -- pragma has no purpose, so it is simply ignored. Not clear if
12304 -- there are any such targets now.
12306 if Opt
.Address_Is_Private
then
12307 Opt
.Allow_Integer_Address
:= True;
12315 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12316 -- ARG ::= NAME | EXPRESSION
12318 -- The first two arguments are by convention intended to refer to an
12319 -- external tool and a tool-specific function. These arguments are
12322 when Pragma_Annotate
=> Annotate
: declare
12329 Check_At_Least_N_Arguments
(1);
12331 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12333 -- Determine whether the last argument is "Entity => local_NAME"
12334 -- and if it is, perform the required semantic checks. Remove the
12335 -- argument from further processing.
12337 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12338 and then Chars
(Nam_Arg
) = Name_Entity
12340 Check_Arg_Is_Local_Name
(Nam_Arg
);
12341 Arg_Count
:= Arg_Count
- 1;
12343 -- A pragma that applies to a Ghost entity becomes Ghost for
12344 -- the purposes of legality checks and removal of ignored Ghost
12347 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12348 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12350 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12353 -- Not allowed in compiler units (bootstrap issues)
12355 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12358 -- Continue the processing with last argument removed for now
12360 Check_Arg_Is_Identifier
(Arg1
);
12361 Check_No_Identifiers
;
12364 -- The second parameter is optional, it is never analyzed
12369 -- Otherwise there is a second parameter
12372 -- The second parameter must be an identifier
12374 Check_Arg_Is_Identifier
(Arg2
);
12376 -- Process the remaining parameters (if any)
12378 Arg
:= Next
(Arg2
);
12379 while Present
(Arg
) loop
12380 Expr
:= Get_Pragma_Arg
(Arg
);
12383 if Is_Entity_Name
(Expr
) then
12386 -- For string literals, we assume Standard_String as the
12387 -- type, unless the string contains wide or wide_wide
12390 elsif Nkind
(Expr
) = N_String_Literal
then
12391 if Has_Wide_Wide_Character
(Expr
) then
12392 Resolve
(Expr
, Standard_Wide_Wide_String
);
12393 elsif Has_Wide_Character
(Expr
) then
12394 Resolve
(Expr
, Standard_Wide_String
);
12396 Resolve
(Expr
, Standard_String
);
12399 elsif Is_Overloaded
(Expr
) then
12400 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
12411 -------------------------------------------------
12412 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12413 -------------------------------------------------
12416 -- ( [Check => ] Boolean_EXPRESSION
12417 -- [, [Message =>] Static_String_EXPRESSION]);
12419 -- pragma Assert_And_Cut
12420 -- ( [Check => ] Boolean_EXPRESSION
12421 -- [, [Message =>] Static_String_EXPRESSION]);
12424 -- ( [Check => ] Boolean_EXPRESSION
12425 -- [, [Message =>] Static_String_EXPRESSION]);
12427 -- pragma Loop_Invariant
12428 -- ( [Check => ] Boolean_EXPRESSION
12429 -- [, [Message =>] Static_String_EXPRESSION]);
12432 | Pragma_Assert_And_Cut
12434 | Pragma_Loop_Invariant
12437 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
12438 -- Determine whether expression Expr contains a Loop_Entry
12439 -- attribute reference.
12441 -------------------------
12442 -- Contains_Loop_Entry --
12443 -------------------------
12445 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
12446 Has_Loop_Entry
: Boolean := False;
12448 function Process
(N
: Node_Id
) return Traverse_Result
;
12449 -- Process function for traversal to look for Loop_Entry
12455 function Process
(N
: Node_Id
) return Traverse_Result
is
12457 if Nkind
(N
) = N_Attribute_Reference
12458 and then Attribute_Name
(N
) = Name_Loop_Entry
12460 Has_Loop_Entry
:= True;
12467 procedure Traverse
is new Traverse_Proc
(Process
);
12469 -- Start of processing for Contains_Loop_Entry
12473 return Has_Loop_Entry
;
12474 end Contains_Loop_Entry
;
12479 New_Args
: List_Id
;
12481 -- Start of processing for Assert
12484 -- Assert is an Ada 2005 RM-defined pragma
12486 if Prag_Id
= Pragma_Assert
then
12489 -- The remaining ones are GNAT pragmas
12495 Check_At_Least_N_Arguments
(1);
12496 Check_At_Most_N_Arguments
(2);
12497 Check_Arg_Order
((Name_Check
, Name_Message
));
12498 Check_Optional_Identifier
(Arg1
, Name_Check
);
12499 Expr
:= Get_Pragma_Arg
(Arg1
);
12501 -- Special processing for Loop_Invariant, Loop_Variant or for
12502 -- other cases where a Loop_Entry attribute is present. If the
12503 -- assertion pragma contains attribute Loop_Entry, ensure that
12504 -- the related pragma is within a loop.
12506 if Prag_Id
= Pragma_Loop_Invariant
12507 or else Prag_Id
= Pragma_Loop_Variant
12508 or else Contains_Loop_Entry
(Expr
)
12510 Check_Loop_Pragma_Placement
;
12512 -- Perform preanalysis to deal with embedded Loop_Entry
12515 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
12518 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12519 -- a corresponding Check pragma:
12521 -- pragma Check (name, condition [, msg]);
12523 -- Where name is the identifier matching the pragma name. So
12524 -- rewrite pragma in this manner, transfer the message argument
12525 -- if present, and analyze the result
12527 -- Note: When dealing with a semantically analyzed tree, the
12528 -- information that a Check node N corresponds to a source Assert,
12529 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12530 -- pragma kind of Original_Node(N).
12532 New_Args
:= New_List
(
12533 Make_Pragma_Argument_Association
(Loc
,
12534 Expression
=> Make_Identifier
(Loc
, Pname
)),
12535 Make_Pragma_Argument_Association
(Sloc
(Expr
),
12536 Expression
=> Expr
));
12538 if Arg_Count
> 1 then
12539 Check_Optional_Identifier
(Arg2
, Name_Message
);
12541 -- Provide semantic annnotations for optional argument, for
12542 -- ASIS use, before rewriting.
12544 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
12545 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
12548 -- Rewrite as Check pragma
12552 Chars
=> Name_Check
,
12553 Pragma_Argument_Associations
=> New_Args
));
12558 ----------------------
12559 -- Assertion_Policy --
12560 ----------------------
12562 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12564 -- The following form is Ada 2012 only, but we allow it in all modes
12566 -- Pragma Assertion_Policy (
12567 -- ASSERTION_KIND => POLICY_IDENTIFIER
12568 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12570 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12572 -- RM_ASSERTION_KIND ::= Assert |
12573 -- Static_Predicate |
12574 -- Dynamic_Predicate |
12579 -- Type_Invariant |
12580 -- Type_Invariant'Class
12582 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12584 -- Contract_Cases |
12586 -- Default_Initial_Condition |
12588 -- Initial_Condition |
12589 -- Loop_Invariant |
12595 -- Statement_Assertions
12597 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12598 -- ID_ASSERTION_KIND list contains implementation-defined additions
12599 -- recognized by GNAT. The effect is to control the behavior of
12600 -- identically named aspects and pragmas, depending on the specified
12601 -- policy identifier:
12603 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12605 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12606 -- implementation-defined addition that results in totally ignoring
12607 -- the corresponding assertion. If Disable is specified, then the
12608 -- argument of the assertion is not even analyzed. This is useful
12609 -- when the aspect/pragma argument references entities in a with'ed
12610 -- package that is replaced by a dummy package in the final build.
12612 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12613 -- and Type_Invariant'Class were recognized by the parser and
12614 -- transformed into references to the special internal identifiers
12615 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12616 -- processing is required here.
12618 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12619 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12620 -- Converts the assertion policy 'Suppressible' to either Check or
12621 -- Ignore based on whether checks are suppressed via -gnatp.
12623 --------------------------
12624 -- Resolve_Suppressible --
12625 --------------------------
12627 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12628 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12632 -- Transform policy argument Suppressible into either Ignore or
12633 -- Check depending on whether checks are enabled or suppressed.
12635 if Chars
(Arg
) = Name_Suppressible
then
12636 if Suppress_Checks
then
12637 Nam
:= Name_Ignore
;
12642 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12644 end Resolve_Suppressible
;
12656 -- This can always appear as a configuration pragma
12658 if Is_Configuration_Pragma
then
12661 -- It can also appear in a declarative part or package spec in Ada
12662 -- 2012 mode. We allow this in other modes, but in that case we
12663 -- consider that we have an Ada 2012 pragma on our hands.
12666 Check_Is_In_Decl_Part_Or_Package_Spec
;
12670 -- One argument case with no identifier (first form above)
12673 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12674 or else Chars
(Arg1
) = No_Name
)
12676 Check_Arg_Is_One_Of
(Arg1
,
12677 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12679 Resolve_Suppressible
(Arg1
);
12681 -- Treat one argument Assertion_Policy as equivalent to:
12683 -- pragma Check_Policy (Assertion, policy)
12685 -- So rewrite pragma in that manner and link on to the chain
12686 -- of Check_Policy pragmas, marking the pragma as analyzed.
12688 Policy
:= Get_Pragma_Arg
(Arg1
);
12692 Chars
=> Name_Check_Policy
,
12693 Pragma_Argument_Associations
=> New_List
(
12694 Make_Pragma_Argument_Association
(Loc
,
12695 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12697 Make_Pragma_Argument_Association
(Loc
,
12699 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12702 -- Here if we have two or more arguments
12705 Check_At_Least_N_Arguments
(1);
12708 -- Loop through arguments
12711 while Present
(Arg
) loop
12712 LocP
:= Sloc
(Arg
);
12714 -- Kind must be specified
12716 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12717 or else Chars
(Arg
) = No_Name
12720 ("missing assertion kind for pragma%", Arg
);
12723 -- Check Kind and Policy have allowed forms
12725 Kind
:= Chars
(Arg
);
12726 Policy
:= Get_Pragma_Arg
(Arg
);
12728 if not Is_Valid_Assertion_Kind
(Kind
) then
12730 ("invalid assertion kind for pragma%", Arg
);
12733 Check_Arg_Is_One_Of
(Arg
,
12734 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12736 Resolve_Suppressible
(Arg
);
12738 if Kind
= Name_Ghost
then
12740 -- The Ghost policy must be either Check or Ignore
12741 -- (SPARK RM 6.9(6)).
12743 if not Nam_In
(Chars
(Policy
), Name_Check
,
12747 ("argument of pragma % Ghost must be Check or "
12748 & "Ignore", Policy
);
12751 -- Pragma Assertion_Policy specifying a Ghost policy
12752 -- cannot occur within a Ghost subprogram or package
12753 -- (SPARK RM 6.9(14)).
12755 if Ghost_Mode
> None
then
12757 ("pragma % cannot appear within ghost subprogram or "
12762 -- Rewrite the Assertion_Policy pragma as a series of
12763 -- Check_Policy pragmas of the form:
12765 -- Check_Policy (Kind, Policy);
12767 -- Note: the insertion of the pragmas cannot be done with
12768 -- Insert_Action because in the configuration case, there
12769 -- are no scopes on the scope stack and the mechanism will
12772 Insert_Before_And_Analyze
(N
,
12774 Chars
=> Name_Check_Policy
,
12775 Pragma_Argument_Associations
=> New_List
(
12776 Make_Pragma_Argument_Association
(LocP
,
12777 Expression
=> Make_Identifier
(LocP
, Kind
)),
12778 Make_Pragma_Argument_Association
(LocP
,
12779 Expression
=> Policy
))));
12784 -- Rewrite the Assertion_Policy pragma as null since we have
12785 -- now inserted all the equivalent Check pragmas.
12787 Rewrite
(N
, Make_Null_Statement
(Loc
));
12790 end Assertion_Policy
;
12792 ------------------------------
12793 -- Assume_No_Invalid_Values --
12794 ------------------------------
12796 -- pragma Assume_No_Invalid_Values (On | Off);
12798 when Pragma_Assume_No_Invalid_Values
=>
12800 Check_Valid_Configuration_Pragma
;
12801 Check_Arg_Count
(1);
12802 Check_No_Identifiers
;
12803 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12805 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12806 Assume_No_Invalid_Values
:= True;
12808 Assume_No_Invalid_Values
:= False;
12811 --------------------------
12812 -- Attribute_Definition --
12813 --------------------------
12815 -- pragma Attribute_Definition
12816 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12817 -- [Entity =>] LOCAL_NAME,
12818 -- [Expression =>] EXPRESSION | NAME);
12820 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12821 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12826 Check_Arg_Count
(3);
12827 Check_Optional_Identifier
(Arg1
, "attribute");
12828 Check_Optional_Identifier
(Arg2
, "entity");
12829 Check_Optional_Identifier
(Arg3
, "expression");
12831 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12832 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12836 Check_Arg_Is_Local_Name
(Arg2
);
12838 -- If the attribute is not recognized, then issue a warning (not
12839 -- an error), and ignore the pragma.
12841 Aname
:= Chars
(Attribute_Designator
);
12843 if not Is_Attribute_Name
(Aname
) then
12844 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12848 -- Otherwise, rewrite the pragma as an attribute definition clause
12851 Make_Attribute_Definition_Clause
(Loc
,
12852 Name
=> Get_Pragma_Arg
(Arg2
),
12854 Expression
=> Get_Pragma_Arg
(Arg3
)));
12856 end Attribute_Definition
;
12858 ------------------------------------------------------------------
12859 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12860 ------------------------------------------------------------------
12862 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12863 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12864 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12865 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12867 when Pragma_Async_Readers
12868 | Pragma_Async_Writers
12869 | Pragma_Effective_Reads
12870 | Pragma_Effective_Writes
12872 Async_Effective
: declare
12873 Obj_Decl
: Node_Id
;
12874 Obj_Id
: Entity_Id
;
12878 Check_No_Identifiers
;
12879 Check_At_Most_N_Arguments
(1);
12881 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12883 -- Object declaration
12885 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
12890 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12892 -- Perform minimal verification to ensure that the argument is at
12893 -- least a variable. Subsequent finer grained checks will be done
12894 -- at the end of the declarative region the contains the pragma.
12896 if Ekind
(Obj_Id
) = E_Variable
then
12898 -- A pragma that applies to a Ghost entity becomes Ghost for
12899 -- the purposes of legality checks and removal of ignored Ghost
12902 Mark_Ghost_Pragma
(N
, Obj_Id
);
12904 -- Chain the pragma on the contract for further processing by
12905 -- Analyze_External_Property_In_Decl_Part.
12907 Add_Contract_Item
(N
, Obj_Id
);
12909 -- Analyze the Boolean expression (if any)
12911 if Present
(Arg1
) then
12912 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12915 -- Otherwise the external property applies to a constant
12918 Error_Pragma
("pragma % must apply to a volatile object");
12920 end Async_Effective
;
12926 -- pragma Asynchronous (LOCAL_NAME);
12928 when Pragma_Asynchronous
=> Asynchronous
: declare
12931 Formal
: Entity_Id
;
12936 procedure Process_Async_Pragma
;
12937 -- Common processing for procedure and access-to-procedure case
12939 --------------------------
12940 -- Process_Async_Pragma --
12941 --------------------------
12943 procedure Process_Async_Pragma
is
12946 Set_Is_Asynchronous
(Nm
);
12950 -- The formals should be of mode IN (RM E.4.1(6))
12953 while Present
(S
) loop
12954 Formal
:= Defining_Identifier
(S
);
12956 if Nkind
(Formal
) = N_Defining_Identifier
12957 and then Ekind
(Formal
) /= E_In_Parameter
12960 ("pragma% procedure can only have IN parameter",
12967 Set_Is_Asynchronous
(Nm
);
12968 end Process_Async_Pragma
;
12970 -- Start of processing for pragma Asynchronous
12973 Check_Ada_83_Warning
;
12974 Check_No_Identifiers
;
12975 Check_Arg_Count
(1);
12976 Check_Arg_Is_Local_Name
(Arg1
);
12978 if Debug_Flag_U
then
12982 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12983 Analyze
(Get_Pragma_Arg
(Arg1
));
12984 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12986 -- A pragma that applies to a Ghost entity becomes Ghost for the
12987 -- purposes of legality checks and removal of ignored Ghost code.
12989 Mark_Ghost_Pragma
(N
, Nm
);
12991 if not Is_Remote_Call_Interface
(C_Ent
)
12992 and then not Is_Remote_Types
(C_Ent
)
12994 -- This pragma should only appear in an RCI or Remote Types
12995 -- unit (RM E.4.1(4)).
12998 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13001 if Ekind
(Nm
) = E_Procedure
13002 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13004 if not Is_Remote_Call_Interface
(Nm
) then
13006 ("pragma% cannot be applied on non-remote procedure",
13010 L
:= Parameter_Specifications
(Parent
(Nm
));
13011 Process_Async_Pragma
;
13014 elsif Ekind
(Nm
) = E_Function
then
13016 ("pragma% cannot be applied to function", Arg1
);
13018 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13019 if Is_Record_Type
(Nm
) then
13021 -- A record type that is the Equivalent_Type for a remote
13022 -- access-to-subprogram type.
13024 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13027 -- A non-expanded RAS type (distribution is not enabled)
13029 Decl
:= Declaration_Node
(Nm
);
13032 if Nkind
(Decl
) = N_Full_Type_Declaration
13033 and then Nkind
(Type_Definition
(Decl
)) =
13034 N_Access_Procedure_Definition
13036 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13037 Process_Async_Pragma
;
13039 if Is_Asynchronous
(Nm
)
13040 and then Expander_Active
13041 and then Get_PCS_Name
/= Name_No_DSA
13043 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13048 ("pragma% cannot reference access-to-function type",
13052 -- Only other possibility is Access-to-class-wide type
13054 elsif Is_Access_Type
(Nm
)
13055 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13057 Check_First_Subtype
(Arg1
);
13058 Set_Is_Asynchronous
(Nm
);
13059 if Expander_Active
then
13060 RACW_Type_Is_Asynchronous
(Nm
);
13064 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13072 -- pragma Atomic (LOCAL_NAME);
13074 when Pragma_Atomic
=>
13075 Process_Atomic_Independent_Shared_Volatile
;
13077 -----------------------
13078 -- Atomic_Components --
13079 -----------------------
13081 -- pragma Atomic_Components (array_LOCAL_NAME);
13083 -- This processing is shared by Volatile_Components
13085 when Pragma_Atomic_Components
13086 | Pragma_Volatile_Components
13088 Atomic_Components
: declare
13095 Check_Ada_83_Warning
;
13096 Check_No_Identifiers
;
13097 Check_Arg_Count
(1);
13098 Check_Arg_Is_Local_Name
(Arg1
);
13099 E_Id
:= Get_Pragma_Arg
(Arg1
);
13101 if Etype
(E_Id
) = Any_Type
then
13105 E
:= Entity
(E_Id
);
13107 -- A pragma that applies to a Ghost entity becomes Ghost for the
13108 -- purposes of legality checks and removal of ignored Ghost code.
13110 Mark_Ghost_Pragma
(N
, E
);
13111 Check_Duplicate_Pragma
(E
);
13113 if Rep_Item_Too_Early
(E
, N
)
13115 Rep_Item_Too_Late
(E
, N
)
13120 D
:= Declaration_Node
(E
);
13123 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13125 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13126 and then Nkind
(D
) = N_Object_Declaration
13127 and then Nkind
(Object_Definition
(D
)) =
13128 N_Constrained_Array_Definition
)
13130 -- The flag is set on the object, or on the base type
13132 if Nkind
(D
) /= N_Object_Declaration
then
13133 E
:= Base_Type
(E
);
13136 -- Atomic implies both Independent and Volatile
13138 if Prag_Id
= Pragma_Atomic_Components
then
13139 Set_Has_Atomic_Components
(E
);
13140 Set_Has_Independent_Components
(E
);
13143 Set_Has_Volatile_Components
(E
);
13146 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13148 end Atomic_Components
;
13150 --------------------
13151 -- Attach_Handler --
13152 --------------------
13154 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13156 when Pragma_Attach_Handler
=>
13157 Check_Ada_83_Warning
;
13158 Check_No_Identifiers
;
13159 Check_Arg_Count
(2);
13161 if No_Run_Time_Mode
then
13162 Error_Msg_CRT
("Attach_Handler pragma", N
);
13164 Check_Interrupt_Or_Attach_Handler
;
13166 -- The expression that designates the attribute may depend on a
13167 -- discriminant, and is therefore a per-object expression, to
13168 -- be expanded in the init proc. If expansion is enabled, then
13169 -- perform semantic checks on a copy only.
13174 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13177 -- In Relaxed_RM_Semantics mode, we allow any static
13178 -- integer value, for compatibility with other compilers.
13180 if Relaxed_RM_Semantics
13181 and then Nkind
(Parg2
) = N_Integer_Literal
13183 Typ
:= Standard_Integer
;
13185 Typ
:= RTE
(RE_Interrupt_ID
);
13188 if Expander_Active
then
13189 Temp
:= New_Copy_Tree
(Parg2
);
13190 Set_Parent
(Temp
, N
);
13191 Preanalyze_And_Resolve
(Temp
, Typ
);
13194 Resolve
(Parg2
, Typ
);
13198 Process_Interrupt_Or_Attach_Handler
;
13201 --------------------
13202 -- C_Pass_By_Copy --
13203 --------------------
13205 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13207 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13213 Check_Valid_Configuration_Pragma
;
13214 Check_Arg_Count
(1);
13215 Check_Optional_Identifier
(Arg1
, "max_size");
13217 Arg
:= Get_Pragma_Arg
(Arg1
);
13218 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13220 Val
:= Expr_Value
(Arg
);
13224 ("maximum size for pragma% must be positive", Arg1
);
13226 elsif UI_Is_In_Int_Range
(Val
) then
13227 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13229 -- If a giant value is given, Int'Last will do well enough.
13230 -- If sometime someone complains that a record larger than
13231 -- two gigabytes is not copied, we will worry about it then.
13234 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13236 end C_Pass_By_Copy
;
13242 -- pragma Check ([Name =>] CHECK_KIND,
13243 -- [Check =>] Boolean_EXPRESSION
13244 -- [,[Message =>] String_EXPRESSION]);
13246 -- CHECK_KIND ::= IDENTIFIER |
13249 -- Invariant'Class |
13250 -- Type_Invariant'Class
13252 -- The identifiers Assertions and Statement_Assertions are not
13253 -- allowed, since they have special meaning for Check_Policy.
13255 -- WARNING: The code below manages Ghost regions. Return statements
13256 -- must be replaced by gotos which jump to the end of the code and
13257 -- restore the Ghost mode.
13259 when Pragma_Check
=> Check
: declare
13260 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13261 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13262 -- Save the Ghost-related attributes to restore on exit
13268 pragma Warnings
(Off
, Str
);
13271 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13272 -- the mode now to ensure that any nodes generated during analysis
13273 -- and expansion are marked as Ghost.
13275 Set_Ghost_Mode
(N
);
13278 Check_At_Least_N_Arguments
(2);
13279 Check_At_Most_N_Arguments
(3);
13280 Check_Optional_Identifier
(Arg1
, Name_Name
);
13281 Check_Optional_Identifier
(Arg2
, Name_Check
);
13283 if Arg_Count
= 3 then
13284 Check_Optional_Identifier
(Arg3
, Name_Message
);
13285 Str
:= Get_Pragma_Arg
(Arg3
);
13288 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13289 Check_Arg_Is_Identifier
(Arg1
);
13290 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13292 -- Check forbidden name Assertions or Statement_Assertions
13295 when Name_Assertions
=>
13297 ("""Assertions"" is not allowed as a check kind for "
13298 & "pragma%", Arg1
);
13300 when Name_Statement_Assertions
=>
13302 ("""Statement_Assertions"" is not allowed as a check kind "
13303 & "for pragma%", Arg1
);
13309 -- Check applicable policy. We skip this if Checked/Ignored status
13310 -- is already set (e.g. in the case of a pragma from an aspect).
13312 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13315 -- For a non-source pragma that is a rewriting of another pragma,
13316 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13318 elsif Is_Rewrite_Substitution
(N
)
13319 and then Nkind
(Original_Node
(N
)) = N_Pragma
13321 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13322 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13324 -- Otherwise query the applicable policy at this point
13327 case Check_Kind
(Cname
) is
13328 when Name_Ignore
=>
13329 Set_Is_Ignored
(N
, True);
13330 Set_Is_Checked
(N
, False);
13333 Set_Is_Ignored
(N
, False);
13334 Set_Is_Checked
(N
, True);
13336 -- For disable, rewrite pragma as null statement and skip
13337 -- rest of the analysis of the pragma.
13339 when Name_Disable
=>
13340 Rewrite
(N
, Make_Null_Statement
(Loc
));
13344 -- No other possibilities
13347 raise Program_Error
;
13351 -- If check kind was not Disable, then continue pragma analysis
13353 Expr
:= Get_Pragma_Arg
(Arg2
);
13355 -- Deal with SCO generation
13357 if Is_Checked
(N
) and then not Split_PPC
(N
) then
13358 Set_SCO_Pragma_Enabled
(Loc
);
13361 -- Deal with analyzing the string argument. If checks are not
13362 -- on we don't want any expansion (since such expansion would
13363 -- not get properly deleted) but we do want to analyze (to get
13364 -- proper references). The Preanalyze_And_Resolve routine does
13365 -- just what we want. Ditto if pragma is active, because it will
13366 -- be rewritten as an if-statement whose analysis will complete
13367 -- analysis and expansion of the string message. This makes a
13368 -- difference in the unusual case where the expression for the
13369 -- string may have a side effect, such as raising an exception.
13370 -- This is mandated by RM 11.4.2, which specifies that the string
13371 -- expression is only evaluated if the check fails and
13372 -- Assertion_Error is to be raised.
13374 if Arg_Count
= 3 then
13375 Preanalyze_And_Resolve
(Str
, Standard_String
);
13378 -- Now you might think we could just do the same with the Boolean
13379 -- expression if checks are off (and expansion is on) and then
13380 -- rewrite the check as a null statement. This would work but we
13381 -- would lose the useful warnings about an assertion being bound
13382 -- to fail even if assertions are turned off.
13384 -- So instead we wrap the boolean expression in an if statement
13385 -- that looks like:
13387 -- if False and then condition then
13391 -- The reason we do this rewriting during semantic analysis rather
13392 -- than as part of normal expansion is that we cannot analyze and
13393 -- expand the code for the boolean expression directly, or it may
13394 -- cause insertion of actions that would escape the attempt to
13395 -- suppress the check code.
13397 -- Note that the Sloc for the if statement corresponds to the
13398 -- argument condition, not the pragma itself. The reason for
13399 -- this is that we may generate a warning if the condition is
13400 -- False at compile time, and we do not want to delete this
13401 -- warning when we delete the if statement.
13403 if Expander_Active
and Is_Ignored
(N
) then
13404 Eloc
:= Sloc
(Expr
);
13407 Make_If_Statement
(Eloc
,
13409 Make_And_Then
(Eloc
,
13410 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
13411 Right_Opnd
=> Expr
),
13412 Then_Statements
=> New_List
(
13413 Make_Null_Statement
(Eloc
))));
13415 -- Now go ahead and analyze the if statement
13417 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13419 -- One rather special treatment. If we are now in Eliminated
13420 -- overflow mode, then suppress overflow checking since we do
13421 -- not want to drag in the bignum stuff if we are in Ignore
13422 -- mode anyway. This is particularly important if we are using
13423 -- a configurable run time that does not support bignum ops.
13425 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
13427 Svo
: constant Boolean :=
13428 Scope_Suppress
.Suppress
(Overflow_Check
);
13430 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
13431 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
13433 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
13434 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
13437 -- Not that special case
13443 -- All done with this check
13445 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13447 -- Check is active or expansion not active. In these cases we can
13448 -- just go ahead and analyze the boolean with no worries.
13451 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13452 Analyze_And_Resolve
(Expr
, Any_Boolean
);
13453 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13456 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
13459 --------------------------
13460 -- Check_Float_Overflow --
13461 --------------------------
13463 -- pragma Check_Float_Overflow;
13465 when Pragma_Check_Float_Overflow
=>
13467 Check_Valid_Configuration_Pragma
;
13468 Check_Arg_Count
(0);
13469 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
13475 -- pragma Check_Name (check_IDENTIFIER);
13477 when Pragma_Check_Name
=>
13479 Check_No_Identifiers
;
13480 Check_Valid_Configuration_Pragma
;
13481 Check_Arg_Count
(1);
13482 Check_Arg_Is_Identifier
(Arg1
);
13485 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
13488 for J
in Check_Names
.First
.. Check_Names
.Last
loop
13489 if Check_Names
.Table
(J
) = Nam
then
13494 Check_Names
.Append
(Nam
);
13501 -- This is the old style syntax, which is still allowed in all modes:
13503 -- pragma Check_Policy ([Name =>] CHECK_KIND
13504 -- [Policy =>] POLICY_IDENTIFIER);
13506 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13508 -- CHECK_KIND ::= IDENTIFIER |
13511 -- Type_Invariant'Class |
13514 -- This is the new style syntax, compatible with Assertion_Policy
13515 -- and also allowed in all modes.
13517 -- Pragma Check_Policy (
13518 -- CHECK_KIND => POLICY_IDENTIFIER
13519 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13521 -- Note: the identifiers Name and Policy are not allowed as
13522 -- Check_Kind values. This avoids ambiguities between the old and
13523 -- new form syntax.
13525 when Pragma_Check_Policy
=> Check_Policy
: declare
13530 Check_At_Least_N_Arguments
(1);
13532 -- A Check_Policy pragma can appear either as a configuration
13533 -- pragma, or in a declarative part or a package spec (see RM
13534 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13535 -- followed for Check_Policy).
13537 if not Is_Configuration_Pragma
then
13538 Check_Is_In_Decl_Part_Or_Package_Spec
;
13541 -- Figure out if we have the old or new syntax. We have the
13542 -- old syntax if the first argument has no identifier, or the
13543 -- identifier is Name.
13545 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
13546 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
13550 Check_Arg_Count
(2);
13551 Check_Optional_Identifier
(Arg1
, Name_Name
);
13552 Kind
:= Get_Pragma_Arg
(Arg1
);
13553 Rewrite_Assertion_Kind
(Kind
,
13554 From_Policy
=> Comes_From_Source
(N
));
13555 Check_Arg_Is_Identifier
(Arg1
);
13557 -- Check forbidden check kind
13559 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
13560 Error_Msg_Name_2
:= Chars
(Kind
);
13562 ("pragma% does not allow% as check name", Arg1
);
13567 Check_Optional_Identifier
(Arg2
, Name_Policy
);
13568 Check_Arg_Is_One_Of
13570 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
13572 -- And chain pragma on the Check_Policy_List for search
13574 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
13575 Opt
.Check_Policy_List
:= N
;
13577 -- For the new syntax, what we do is to convert each argument to
13578 -- an old syntax equivalent. We do that because we want to chain
13579 -- old style Check_Policy pragmas for the search (we don't want
13580 -- to have to deal with multiple arguments in the search).
13591 while Present
(Arg
) loop
13592 LocP
:= Sloc
(Arg
);
13593 Argx
:= Get_Pragma_Arg
(Arg
);
13595 -- Kind must be specified
13597 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13598 or else Chars
(Arg
) = No_Name
13601 ("missing assertion kind for pragma%", Arg
);
13604 -- Construct equivalent old form syntax Check_Policy
13605 -- pragma and insert it to get remaining checks.
13609 Chars
=> Name_Check_Policy
,
13610 Pragma_Argument_Associations
=> New_List
(
13611 Make_Pragma_Argument_Association
(LocP
,
13613 Make_Identifier
(LocP
, Chars
(Arg
))),
13614 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13615 Expression
=> Argx
)));
13619 -- For a configuration pragma, insert old form in
13620 -- the corresponding file.
13622 if Is_Configuration_Pragma
then
13623 Insert_After
(N
, New_P
);
13627 Insert_Action
(N
, New_P
);
13631 -- Rewrite original Check_Policy pragma to null, since we
13632 -- have converted it into a series of old syntax pragmas.
13634 Rewrite
(N
, Make_Null_Statement
(Loc
));
13644 -- pragma Comment (static_string_EXPRESSION)
13646 -- Processing for pragma Comment shares the circuitry for pragma
13647 -- Ident. The only differences are that Ident enforces a limit of 31
13648 -- characters on its argument, and also enforces limitations on
13649 -- placement for DEC compatibility. Pragma Comment shares neither of
13650 -- these restrictions.
13652 -------------------
13653 -- Common_Object --
13654 -------------------
13656 -- pragma Common_Object (
13657 -- [Internal =>] LOCAL_NAME
13658 -- [, [External =>] EXTERNAL_SYMBOL]
13659 -- [, [Size =>] EXTERNAL_SYMBOL]);
13661 -- Processing for this pragma is shared with Psect_Object
13663 ------------------------
13664 -- Compile_Time_Error --
13665 ------------------------
13667 -- pragma Compile_Time_Error
13668 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13670 when Pragma_Compile_Time_Error
=>
13672 Process_Compile_Time_Warning_Or_Error
;
13674 --------------------------
13675 -- Compile_Time_Warning --
13676 --------------------------
13678 -- pragma Compile_Time_Warning
13679 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13681 when Pragma_Compile_Time_Warning
=>
13683 Process_Compile_Time_Warning_Or_Error
;
13685 ---------------------------
13686 -- Compiler_Unit_Warning --
13687 ---------------------------
13689 -- pragma Compiler_Unit_Warning;
13693 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13694 -- errors not warnings. This means that we had introduced a big extra
13695 -- inertia to compiler changes, since even if we implemented a new
13696 -- feature, and even if all versions to be used for bootstrapping
13697 -- implemented this new feature, we could not use it, since old
13698 -- compilers would give errors for using this feature in units
13699 -- having Compiler_Unit pragmas.
13701 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13702 -- problem. We no longer have any units mentioning Compiler_Unit,
13703 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13704 -- and thus generates a warning which can be ignored. So that deals
13705 -- with the problem of old compilers not implementing the newer form
13708 -- Newer compilers recognize the new pragma, but generate warning
13709 -- messages instead of errors, which again can be ignored in the
13710 -- case of an old compiler which implements a wanted new feature
13711 -- but at the time felt like warning about it for older compilers.
13713 -- We retain Compiler_Unit so that new compilers can be used to build
13714 -- older run-times that use this pragma. That's an unusual case, but
13715 -- it's easy enough to handle, so why not?
13717 when Pragma_Compiler_Unit
13718 | Pragma_Compiler_Unit_Warning
13721 Check_Arg_Count
(0);
13723 -- Only recognized in main unit
13725 if Current_Sem_Unit
= Main_Unit
then
13726 Compiler_Unit
:= True;
13729 -----------------------------
13730 -- Complete_Representation --
13731 -----------------------------
13733 -- pragma Complete_Representation;
13735 when Pragma_Complete_Representation
=>
13737 Check_Arg_Count
(0);
13739 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13741 ("pragma & must appear within record representation clause");
13744 ----------------------------
13745 -- Complex_Representation --
13746 ----------------------------
13748 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13750 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13757 Check_Arg_Count
(1);
13758 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13759 Check_Arg_Is_Local_Name
(Arg1
);
13760 E_Id
:= Get_Pragma_Arg
(Arg1
);
13762 if Etype
(E_Id
) = Any_Type
then
13766 E
:= Entity
(E_Id
);
13768 if not Is_Record_Type
(E
) then
13770 ("argument for pragma% must be record type", Arg1
);
13773 Ent
:= First_Entity
(E
);
13776 or else No
(Next_Entity
(Ent
))
13777 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13778 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13779 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13782 ("record for pragma% must have two fields of the same "
13783 & "floating-point type", Arg1
);
13786 Set_Has_Complex_Representation
(Base_Type
(E
));
13788 -- We need to treat the type has having a non-standard
13789 -- representation, for back-end purposes, even though in
13790 -- general a complex will have the default representation
13791 -- of a record with two real components.
13793 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13795 end Complex_Representation
;
13797 -------------------------
13798 -- Component_Alignment --
13799 -------------------------
13801 -- pragma Component_Alignment (
13802 -- [Form =>] ALIGNMENT_CHOICE
13803 -- [, [Name =>] type_LOCAL_NAME]);
13805 -- ALIGNMENT_CHOICE ::=
13807 -- | Component_Size_4
13811 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13812 Args
: Args_List
(1 .. 2);
13813 Names
: constant Name_List
(1 .. 2) := (
13817 Form
: Node_Id
renames Args
(1);
13818 Name
: Node_Id
renames Args
(2);
13820 Atype
: Component_Alignment_Kind
;
13825 Gather_Associations
(Names
, Args
);
13828 Error_Pragma
("missing Form argument for pragma%");
13831 Check_Arg_Is_Identifier
(Form
);
13833 -- Get proper alignment, note that Default = Component_Size on all
13834 -- machines we have so far, and we want to set this value rather
13835 -- than the default value to indicate that it has been explicitly
13836 -- set (and thus will not get overridden by the default component
13837 -- alignment for the current scope)
13839 if Chars
(Form
) = Name_Component_Size
then
13840 Atype
:= Calign_Component_Size
;
13842 elsif Chars
(Form
) = Name_Component_Size_4
then
13843 Atype
:= Calign_Component_Size_4
;
13845 elsif Chars
(Form
) = Name_Default
then
13846 Atype
:= Calign_Component_Size
;
13848 elsif Chars
(Form
) = Name_Storage_Unit
then
13849 Atype
:= Calign_Storage_Unit
;
13853 ("invalid Form parameter for pragma%", Form
);
13856 -- The pragma appears in a configuration file
13858 if No
(Parent
(N
)) then
13859 Check_Valid_Configuration_Pragma
;
13861 -- Capture the component alignment in a global variable when
13862 -- the pragma appears in a configuration file. Note that the
13863 -- scope stack is empty at this point and cannot be used to
13864 -- store the alignment value.
13866 Configuration_Component_Alignment
:= Atype
;
13868 -- Case with no name, supplied, affects scope table entry
13870 elsif No
(Name
) then
13872 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13874 -- Case of name supplied
13877 Check_Arg_Is_Local_Name
(Name
);
13879 Typ
:= Entity
(Name
);
13882 or else Rep_Item_Too_Early
(Typ
, N
)
13886 Typ
:= Underlying_Type
(Typ
);
13889 if not Is_Record_Type
(Typ
)
13890 and then not Is_Array_Type
(Typ
)
13893 ("Name parameter of pragma% must identify record or "
13894 & "array type", Name
);
13897 -- An explicit Component_Alignment pragma overrides an
13898 -- implicit pragma Pack, but not an explicit one.
13900 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13901 Set_Is_Packed
(Base_Type
(Typ
), False);
13902 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13905 end Component_AlignmentP
;
13907 --------------------------------
13908 -- Constant_After_Elaboration --
13909 --------------------------------
13911 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13913 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13915 Obj_Decl
: Node_Id
;
13916 Obj_Id
: Entity_Id
;
13920 Check_No_Identifiers
;
13921 Check_At_Most_N_Arguments
(1);
13923 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13925 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
13930 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13932 -- The object declaration must be a library-level variable which
13933 -- is either explicitly initialized or obtains a value during the
13934 -- elaboration of a package body (SPARK RM 3.3.1).
13936 if Ekind
(Obj_Id
) = E_Variable
then
13937 if not Is_Library_Level_Entity
(Obj_Id
) then
13939 ("pragma % must apply to a library level variable");
13943 -- Otherwise the pragma applies to a constant, which is illegal
13946 Error_Pragma
("pragma % must apply to a variable declaration");
13950 -- A pragma that applies to a Ghost entity becomes Ghost for the
13951 -- purposes of legality checks and removal of ignored Ghost code.
13953 Mark_Ghost_Pragma
(N
, Obj_Id
);
13955 -- Chain the pragma on the contract for completeness
13957 Add_Contract_Item
(N
, Obj_Id
);
13959 -- Analyze the Boolean expression (if any)
13961 if Present
(Arg1
) then
13962 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13964 end Constant_After_Elaboration
;
13966 --------------------
13967 -- Contract_Cases --
13968 --------------------
13970 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13972 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13974 -- CASE_GUARD ::= boolean_EXPRESSION | others
13976 -- CONSEQUENCE ::= boolean_EXPRESSION
13978 -- Characteristics:
13980 -- * Analysis - The annotation undergoes initial checks to verify
13981 -- the legal placement and context. Secondary checks preanalyze the
13984 -- Analyze_Contract_Cases_In_Decl_Part
13986 -- * Expansion - The annotation is expanded during the expansion of
13987 -- the related subprogram [body] contract as performed in:
13989 -- Expand_Subprogram_Contract
13991 -- * Template - The annotation utilizes the generic template of the
13992 -- related subprogram [body] when it is:
13994 -- aspect on subprogram declaration
13995 -- aspect on stand-alone subprogram body
13996 -- pragma on stand-alone subprogram body
13998 -- The annotation must prepare its own template when it is:
14000 -- pragma on subprogram declaration
14002 -- * Globals - Capture of global references must occur after full
14005 -- * Instance - The annotation is instantiated automatically when
14006 -- the related generic subprogram [body] is instantiated except for
14007 -- the "pragma on subprogram declaration" case. In that scenario
14008 -- the annotation must instantiate itself.
14010 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14011 Spec_Id
: Entity_Id
;
14012 Subp_Decl
: Node_Id
;
14013 Subp_Spec
: Node_Id
;
14017 Check_No_Identifiers
;
14018 Check_Arg_Count
(1);
14020 -- Ensure the proper placement of the pragma. Contract_Cases must
14021 -- be associated with a subprogram declaration or a body that acts
14025 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14029 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14032 -- Generic subprogram
14034 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14037 -- Body acts as spec
14039 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14040 and then No
(Corresponding_Spec
(Subp_Decl
))
14044 -- Body stub acts as spec
14046 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14047 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14053 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14054 Subp_Spec
:= Specification
(Subp_Decl
);
14056 -- Pragma Contract_Cases is forbidden on null procedures, as
14057 -- this may lead to potential ambiguities in behavior when
14058 -- interface null procedures are involved.
14060 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14061 and then Null_Present
(Subp_Spec
)
14063 Error_Msg_N
(Fix_Error
14064 ("pragma % cannot apply to null procedure"), N
);
14073 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14075 -- A pragma that applies to a Ghost entity becomes Ghost for the
14076 -- purposes of legality checks and removal of ignored Ghost code.
14078 Mark_Ghost_Pragma
(N
, Spec_Id
);
14079 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14081 -- Chain the pragma on the contract for further processing by
14082 -- Analyze_Contract_Cases_In_Decl_Part.
14084 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14086 -- Fully analyze the pragma when it appears inside an entry
14087 -- or subprogram body because it cannot benefit from forward
14090 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14092 N_Subprogram_Body_Stub
)
14094 -- The legality checks of pragma Contract_Cases are affected by
14095 -- the SPARK mode in effect and the volatility of the context.
14096 -- Analyze all pragmas in a specific order.
14098 Analyze_If_Present
(Pragma_SPARK_Mode
);
14099 Analyze_If_Present
(Pragma_Volatile_Function
);
14100 Analyze_Contract_Cases_In_Decl_Part
(N
);
14102 end Contract_Cases
;
14108 -- pragma Controlled (first_subtype_LOCAL_NAME);
14110 when Pragma_Controlled
=> Controlled
: declare
14114 Check_No_Identifiers
;
14115 Check_Arg_Count
(1);
14116 Check_Arg_Is_Local_Name
(Arg1
);
14117 Arg
:= Get_Pragma_Arg
(Arg1
);
14119 if not Is_Entity_Name
(Arg
)
14120 or else not Is_Access_Type
(Entity
(Arg
))
14122 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14124 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14132 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14133 -- [Entity =>] LOCAL_NAME);
14135 when Pragma_Convention
=> Convention
: declare
14138 pragma Warnings
(Off
, C
);
14139 pragma Warnings
(Off
, E
);
14142 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14143 Check_Ada_83_Warning
;
14144 Check_Arg_Count
(2);
14145 Process_Convention
(C
, E
);
14147 -- A pragma that applies to a Ghost entity becomes Ghost for the
14148 -- purposes of legality checks and removal of ignored Ghost code.
14150 Mark_Ghost_Pragma
(N
, E
);
14153 ---------------------------
14154 -- Convention_Identifier --
14155 ---------------------------
14157 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14158 -- [Convention =>] convention_IDENTIFIER);
14160 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14166 Check_Arg_Order
((Name_Name
, Name_Convention
));
14167 Check_Arg_Count
(2);
14168 Check_Optional_Identifier
(Arg1
, Name_Name
);
14169 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14170 Check_Arg_Is_Identifier
(Arg1
);
14171 Check_Arg_Is_Identifier
(Arg2
);
14172 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14173 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14175 if Is_Convention_Name
(Cname
) then
14176 Record_Convention_Identifier
14177 (Idnam
, Get_Convention_Id
(Cname
));
14180 ("second arg for % pragma must be convention", Arg2
);
14182 end Convention_Identifier
;
14188 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14190 when Pragma_CPP_Class
=>
14193 if Warn_On_Obsolescent_Feature
then
14195 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14196 & "effect; replace it by pragma import?j?", N
);
14199 Check_Arg_Count
(1);
14203 Chars
=> Name_Import
,
14204 Pragma_Argument_Associations
=> New_List
(
14205 Make_Pragma_Argument_Association
(Loc
,
14206 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14207 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14210 ---------------------
14211 -- CPP_Constructor --
14212 ---------------------
14214 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14215 -- [, [External_Name =>] static_string_EXPRESSION ]
14216 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14218 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14221 Def_Id
: Entity_Id
;
14222 Tag_Typ
: Entity_Id
;
14226 Check_At_Least_N_Arguments
(1);
14227 Check_At_Most_N_Arguments
(3);
14228 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14229 Check_Arg_Is_Local_Name
(Arg1
);
14231 Id
:= Get_Pragma_Arg
(Arg1
);
14232 Find_Program_Unit_Name
(Id
);
14234 -- If we did not find the name, we are done
14236 if Etype
(Id
) = Any_Type
then
14240 Def_Id
:= Entity
(Id
);
14242 -- Check if already defined as constructor
14244 if Is_Constructor
(Def_Id
) then
14246 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14250 if Ekind
(Def_Id
) = E_Function
14251 and then (Is_CPP_Class
(Etype
(Def_Id
))
14252 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14254 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14256 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14258 ("'C'P'P constructor must be defined in the scope of "
14259 & "its returned type", Arg1
);
14262 if Arg_Count
>= 2 then
14263 Set_Imported
(Def_Id
);
14264 Set_Is_Public
(Def_Id
);
14265 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14268 Set_Has_Completion
(Def_Id
);
14269 Set_Is_Constructor
(Def_Id
);
14270 Set_Convention
(Def_Id
, Convention_CPP
);
14272 -- Imported C++ constructors are not dispatching primitives
14273 -- because in C++ they don't have a dispatch table slot.
14274 -- However, in Ada the constructor has the profile of a
14275 -- function that returns a tagged type and therefore it has
14276 -- been treated as a primitive operation during semantic
14277 -- analysis. We now remove it from the list of primitive
14278 -- operations of the type.
14280 if Is_Tagged_Type
(Etype
(Def_Id
))
14281 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14282 and then Is_Dispatching_Operation
(Def_Id
)
14284 Tag_Typ
:= Etype
(Def_Id
);
14286 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14287 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14291 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14292 Set_Is_Dispatching_Operation
(Def_Id
, False);
14295 -- For backward compatibility, if the constructor returns a
14296 -- class wide type, and we internally change the return type to
14297 -- the corresponding root type.
14299 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14300 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14304 ("pragma% requires function returning a 'C'P'P_Class type",
14307 end CPP_Constructor
;
14313 when Pragma_CPP_Virtual
=>
14316 if Warn_On_Obsolescent_Feature
then
14318 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14326 when Pragma_CPP_Vtable
=>
14329 if Warn_On_Obsolescent_Feature
then
14331 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14339 -- pragma CPU (EXPRESSION);
14341 when Pragma_CPU
=> CPU
: declare
14342 P
: constant Node_Id
:= Parent
(N
);
14348 Check_No_Identifiers
;
14349 Check_Arg_Count
(1);
14353 if Nkind
(P
) = N_Subprogram_Body
then
14354 Check_In_Main_Program
;
14356 Arg
:= Get_Pragma_Arg
(Arg1
);
14357 Analyze_And_Resolve
(Arg
, Any_Integer
);
14359 Ent
:= Defining_Unit_Name
(Specification
(P
));
14361 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
14362 Ent
:= Defining_Identifier
(Ent
);
14367 if not Is_OK_Static_Expression
(Arg
) then
14368 Flag_Non_Static_Expr
14369 ("main subprogram affinity is not static!", Arg
);
14372 -- If constraint error, then we already signalled an error
14374 elsif Raises_Constraint_Error
(Arg
) then
14377 -- Otherwise check in range
14381 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
14382 -- This is the entity System.Multiprocessors.CPU_Range;
14384 Val
: constant Uint
:= Expr_Value
(Arg
);
14387 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
14389 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
14392 ("main subprogram CPU is out of range", Arg1
);
14398 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
14402 elsif Nkind
(P
) = N_Task_Definition
then
14403 Arg
:= Get_Pragma_Arg
(Arg1
);
14404 Ent
:= Defining_Identifier
(Parent
(P
));
14406 -- The expression must be analyzed in the special manner
14407 -- described in "Handling of Default and Per-Object
14408 -- Expressions" in sem.ads.
14410 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
14412 -- Anything else is incorrect
14418 -- Check duplicate pragma before we chain the pragma in the Rep
14419 -- Item chain of Ent.
14421 Check_Duplicate_Pragma
(Ent
);
14422 Record_Rep_Item
(Ent
, N
);
14425 --------------------
14426 -- Deadline_Floor --
14427 --------------------
14429 -- pragma Deadline_Floor (time_span_EXPRESSION);
14431 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
14432 P
: constant Node_Id
:= Parent
(N
);
14438 Check_No_Identifiers
;
14439 Check_Arg_Count
(1);
14441 Arg
:= Get_Pragma_Arg
(Arg1
);
14443 -- The expression must be analyzed in the special manner described
14444 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14446 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
14448 -- Only protected types allowed
14450 if Nkind
(P
) /= N_Protected_Definition
then
14454 Ent
:= Defining_Identifier
(Parent
(P
));
14456 -- Check duplicate pragma before we chain the pragma in the Rep
14457 -- Item chain of Ent.
14459 Check_Duplicate_Pragma
(Ent
);
14460 Record_Rep_Item
(Ent
, N
);
14462 end Deadline_Floor
;
14468 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14470 when Pragma_Debug
=> Debug
: declare
14477 -- The condition for executing the call is that the expander
14478 -- is active and that we are not ignoring this debug pragma.
14483 (Expander_Active
and then not Is_Ignored
(N
)),
14486 if not Is_Ignored
(N
) then
14487 Set_SCO_Pragma_Enabled
(Loc
);
14490 if Arg_Count
= 2 then
14492 Make_And_Then
(Loc
,
14493 Left_Opnd
=> Relocate_Node
(Cond
),
14494 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
14495 Call
:= Get_Pragma_Arg
(Arg2
);
14497 Call
:= Get_Pragma_Arg
(Arg1
);
14500 if Nkind_In
(Call
, N_Expanded_Name
,
14503 N_Indexed_Component
,
14504 N_Selected_Component
)
14506 -- If this pragma Debug comes from source, its argument was
14507 -- parsed as a name form (which is syntactically identical).
14508 -- In a generic context a parameterless call will be left as
14509 -- an expanded name (if global) or selected_component if local.
14510 -- Change it to a procedure call statement now.
14512 Change_Name_To_Procedure_Call_Statement
(Call
);
14514 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
14516 -- Already in the form of a procedure call statement: nothing
14517 -- to do (could happen in case of an internally generated
14523 -- All other cases: diagnose error
14526 ("argument of pragma ""Debug"" is not procedure call",
14531 -- Rewrite into a conditional with an appropriate condition. We
14532 -- wrap the procedure call in a block so that overhead from e.g.
14533 -- use of the secondary stack does not generate execution overhead
14534 -- for suppressed conditions.
14536 -- Normally the analysis that follows will freeze the subprogram
14537 -- being called. However, if the call is to a null procedure,
14538 -- we want to freeze it before creating the block, because the
14539 -- analysis that follows may be done with expansion disabled, in
14540 -- which case the body will not be generated, leading to spurious
14543 if Nkind
(Call
) = N_Procedure_Call_Statement
14544 and then Is_Entity_Name
(Name
(Call
))
14546 Analyze
(Name
(Call
));
14547 Freeze_Before
(N
, Entity
(Name
(Call
)));
14551 Make_Implicit_If_Statement
(N
,
14553 Then_Statements
=> New_List
(
14554 Make_Block_Statement
(Loc
,
14555 Handled_Statement_Sequence
=>
14556 Make_Handled_Sequence_Of_Statements
(Loc
,
14557 Statements
=> New_List
(Relocate_Node
(Call
)))))));
14560 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14561 -- after analysis of the normally rewritten node, to capture all
14562 -- references to entities, which avoids issuing wrong warnings
14563 -- about unused entities.
14565 if GNATprove_Mode
then
14566 Rewrite
(N
, Make_Null_Statement
(Loc
));
14574 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14576 when Pragma_Debug_Policy
=>
14578 Check_Arg_Count
(1);
14579 Check_No_Identifiers
;
14580 Check_Arg_Is_Identifier
(Arg1
);
14582 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14583 -- rewrite it that way, and let the rest of the checking come
14584 -- from analyzing the rewritten pragma.
14588 Chars
=> Name_Check_Policy
,
14589 Pragma_Argument_Associations
=> New_List
(
14590 Make_Pragma_Argument_Association
(Loc
,
14591 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14593 Make_Pragma_Argument_Association
(Loc
,
14594 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14597 -------------------------------
14598 -- Default_Initial_Condition --
14599 -------------------------------
14601 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14603 when Pragma_Default_Initial_Condition
=> DIC
: declare
14610 Check_No_Identifiers
;
14611 Check_At_Most_N_Arguments
(1);
14615 while Present
(Stmt
) loop
14617 -- Skip prior pragmas, but check for duplicates
14619 if Nkind
(Stmt
) = N_Pragma
then
14620 if Pragma_Name
(Stmt
) = Pname
then
14627 -- Skip internally generated code. Note that derived type
14628 -- declarations of untagged types with discriminants are
14629 -- rewritten as private type declarations.
14631 elsif not Comes_From_Source
(Stmt
)
14632 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14636 -- The associated private type [extension] has been found, stop
14639 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14640 N_Private_Type_Declaration
)
14642 Typ
:= Defining_Entity
(Stmt
);
14645 -- The pragma does not apply to a legal construct, issue an
14646 -- error and stop the analysis.
14653 Stmt
:= Prev
(Stmt
);
14656 -- The pragma does not apply to a legal construct, issue an error
14657 -- and stop the analysis.
14664 -- A pragma that applies to a Ghost entity becomes Ghost for the
14665 -- purposes of legality checks and removal of ignored Ghost code.
14667 Mark_Ghost_Pragma
(N
, Typ
);
14669 -- The pragma signals that the type defines its own DIC assertion
14672 Set_Has_Own_DIC
(Typ
);
14674 -- Chain the pragma on the rep item chain for further processing
14676 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14678 -- Create the declaration of the procedure which verifies the
14679 -- assertion expression of pragma DIC at runtime.
14681 Build_DIC_Procedure_Declaration
(Typ
);
14684 ----------------------------------
14685 -- Default_Scalar_Storage_Order --
14686 ----------------------------------
14688 -- pragma Default_Scalar_Storage_Order
14689 -- (High_Order_First | Low_Order_First);
14691 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14692 Default
: Character;
14696 Check_Arg_Count
(1);
14698 -- Default_Scalar_Storage_Order can appear as a configuration
14699 -- pragma, or in a declarative part of a package spec.
14701 if not Is_Configuration_Pragma
then
14702 Check_Is_In_Decl_Part_Or_Package_Spec
;
14705 Check_No_Identifiers
;
14706 Check_Arg_Is_One_Of
14707 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14708 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14709 Default
:= Fold_Upper
(Name_Buffer
(1));
14711 if not Support_Nondefault_SSO_On_Target
14712 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14714 if Warn_On_Unrecognized_Pragma
then
14716 ("non-default Scalar_Storage_Order not supported "
14717 & "on target?g?", N
);
14719 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14722 -- Here set the specified default
14725 Opt
.Default_SSO
:= Default
;
14729 --------------------------
14730 -- Default_Storage_Pool --
14731 --------------------------
14733 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14735 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14740 Check_Arg_Count
(1);
14742 -- Default_Storage_Pool can appear as a configuration pragma, or
14743 -- in a declarative part of a package spec.
14745 if not Is_Configuration_Pragma
then
14746 Check_Is_In_Decl_Part_Or_Package_Spec
;
14749 if From_Aspect_Specification
(N
) then
14751 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14753 if not In_Open_Scopes
(E
) then
14755 ("aspect must apply to package or subprogram", N
);
14760 if Present
(Arg1
) then
14761 Pool
:= Get_Pragma_Arg
(Arg1
);
14763 -- Case of Default_Storage_Pool (null);
14765 if Nkind
(Pool
) = N_Null
then
14768 -- This is an odd case, this is not really an expression,
14769 -- so we don't have a type for it. So just set the type to
14772 Set_Etype
(Pool
, Empty
);
14774 -- Case of Default_Storage_Pool (storage_pool_NAME);
14777 -- If it's a configuration pragma, then the only allowed
14778 -- argument is "null".
14780 if Is_Configuration_Pragma
then
14781 Error_Pragma_Arg
("NULL expected", Arg1
);
14784 -- The expected type for a non-"null" argument is
14785 -- Root_Storage_Pool'Class, and the pool must be a variable.
14787 Analyze_And_Resolve
14788 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14790 if Is_Variable
(Pool
) then
14792 -- A pragma that applies to a Ghost entity becomes Ghost
14793 -- for the purposes of legality checks and removal of
14794 -- ignored Ghost code.
14796 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14800 ("default storage pool must be a variable", Arg1
);
14804 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14805 -- access type will use this information to set the appropriate
14806 -- attributes of the access type. If the pragma appears in a
14807 -- generic unit it is ignored, given that it may refer to a
14810 if not Inside_A_Generic
then
14811 Default_Pool
:= Pool
;
14814 end Default_Storage_Pool
;
14820 -- pragma Depends (DEPENDENCY_RELATION);
14822 -- DEPENDENCY_RELATION ::=
14824 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14826 -- DEPENDENCY_CLAUSE ::=
14827 -- OUTPUT_LIST =>[+] INPUT_LIST
14828 -- | NULL_DEPENDENCY_CLAUSE
14830 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14832 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14834 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14836 -- OUTPUT ::= NAME | FUNCTION_RESULT
14839 -- where FUNCTION_RESULT is a function Result attribute_reference
14841 -- Characteristics:
14843 -- * Analysis - The annotation undergoes initial checks to verify
14844 -- the legal placement and context. Secondary checks fully analyze
14845 -- the dependency clauses in:
14847 -- Analyze_Depends_In_Decl_Part
14849 -- * Expansion - None.
14851 -- * Template - The annotation utilizes the generic template of the
14852 -- related subprogram [body] when it is:
14854 -- aspect on subprogram declaration
14855 -- aspect on stand-alone subprogram body
14856 -- pragma on stand-alone subprogram body
14858 -- The annotation must prepare its own template when it is:
14860 -- pragma on subprogram declaration
14862 -- * Globals - Capture of global references must occur after full
14865 -- * Instance - The annotation is instantiated automatically when
14866 -- the related generic subprogram [body] is instantiated except for
14867 -- the "pragma on subprogram declaration" case. In that scenario
14868 -- the annotation must instantiate itself.
14870 when Pragma_Depends
=> Depends
: declare
14872 Spec_Id
: Entity_Id
;
14873 Subp_Decl
: Node_Id
;
14876 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14880 -- Chain the pragma on the contract for further processing by
14881 -- Analyze_Depends_In_Decl_Part.
14883 Add_Contract_Item
(N
, Spec_Id
);
14885 -- Fully analyze the pragma when it appears inside an entry
14886 -- or subprogram body because it cannot benefit from forward
14889 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14891 N_Subprogram_Body_Stub
)
14893 -- The legality checks of pragmas Depends and Global are
14894 -- affected by the SPARK mode in effect and the volatility
14895 -- of the context. In addition these two pragmas are subject
14896 -- to an inherent order:
14901 -- Analyze all these pragmas in the order outlined above
14903 Analyze_If_Present
(Pragma_SPARK_Mode
);
14904 Analyze_If_Present
(Pragma_Volatile_Function
);
14905 Analyze_If_Present
(Pragma_Global
);
14906 Analyze_Depends_In_Decl_Part
(N
);
14911 ---------------------
14912 -- Detect_Blocking --
14913 ---------------------
14915 -- pragma Detect_Blocking;
14917 when Pragma_Detect_Blocking
=>
14919 Check_Arg_Count
(0);
14920 Check_Valid_Configuration_Pragma
;
14921 Detect_Blocking
:= True;
14923 ------------------------------------
14924 -- Disable_Atomic_Synchronization --
14925 ------------------------------------
14927 -- pragma Disable_Atomic_Synchronization [(Entity)];
14929 when Pragma_Disable_Atomic_Synchronization
=>
14931 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14933 -------------------
14934 -- Discard_Names --
14935 -------------------
14937 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14939 when Pragma_Discard_Names
=> Discard_Names
: declare
14944 Check_Ada_83_Warning
;
14946 -- Deal with configuration pragma case
14948 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14949 Global_Discard_Names
:= True;
14952 -- Otherwise, check correct appropriate context
14955 Check_Is_In_Decl_Part_Or_Package_Spec
;
14957 if Arg_Count
= 0 then
14959 -- If there is no parameter, then from now on this pragma
14960 -- applies to any enumeration, exception or tagged type
14961 -- defined in the current declarative part, and recursively
14962 -- to any nested scope.
14964 Set_Discard_Names
(Current_Scope
);
14968 Check_Arg_Count
(1);
14969 Check_Optional_Identifier
(Arg1
, Name_On
);
14970 Check_Arg_Is_Local_Name
(Arg1
);
14972 E_Id
:= Get_Pragma_Arg
(Arg1
);
14974 if Etype
(E_Id
) = Any_Type
then
14978 E
:= Entity
(E_Id
);
14980 -- A pragma that applies to a Ghost entity becomes Ghost for
14981 -- the purposes of legality checks and removal of ignored
14984 Mark_Ghost_Pragma
(N
, E
);
14986 if (Is_First_Subtype
(E
)
14988 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14989 or else Ekind
(E
) = E_Exception
14991 Set_Discard_Names
(E
);
14992 Record_Rep_Item
(E
, N
);
14996 ("inappropriate entity for pragma%", Arg1
);
15002 ------------------------
15003 -- Dispatching_Domain --
15004 ------------------------
15006 -- pragma Dispatching_Domain (EXPRESSION);
15008 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15009 P
: constant Node_Id
:= Parent
(N
);
15015 Check_No_Identifiers
;
15016 Check_Arg_Count
(1);
15018 -- This pragma is born obsolete, but not the aspect
15020 if not From_Aspect_Specification
(N
) then
15022 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15025 if Nkind
(P
) = N_Task_Definition
then
15026 Arg
:= Get_Pragma_Arg
(Arg1
);
15027 Ent
:= Defining_Identifier
(Parent
(P
));
15029 -- A pragma that applies to a Ghost entity becomes Ghost for
15030 -- the purposes of legality checks and removal of ignored Ghost
15033 Mark_Ghost_Pragma
(N
, Ent
);
15035 -- The expression must be analyzed in the special manner
15036 -- described in "Handling of Default and Per-Object
15037 -- Expressions" in sem.ads.
15039 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15041 -- Check duplicate pragma before we chain the pragma in the Rep
15042 -- Item chain of Ent.
15044 Check_Duplicate_Pragma
(Ent
);
15045 Record_Rep_Item
(Ent
, N
);
15047 -- Anything else is incorrect
15052 end Dispatching_Domain
;
15058 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15060 when Pragma_Elaborate
=> Elaborate
: declare
15065 -- Pragma must be in context items list of a compilation unit
15067 if not Is_In_Context_Clause
then
15071 -- Must be at least one argument
15073 if Arg_Count
= 0 then
15074 Error_Pragma
("pragma% requires at least one argument");
15077 -- In Ada 83 mode, there can be no items following it in the
15078 -- context list except other pragmas and implicit with clauses
15079 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15080 -- placement rule does not apply.
15082 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15084 while Present
(Citem
) loop
15085 if Nkind
(Citem
) = N_Pragma
15086 or else (Nkind
(Citem
) = N_With_Clause
15087 and then Implicit_With
(Citem
))
15092 ("(Ada 83) pragma% must be at end of context clause");
15099 -- Finally, the arguments must all be units mentioned in a with
15100 -- clause in the same context clause. Note we already checked (in
15101 -- Par.Prag) that the arguments are all identifiers or selected
15105 Outer
: while Present
(Arg
) loop
15106 Citem
:= First
(List_Containing
(N
));
15107 Inner
: while Citem
/= N
loop
15108 if Nkind
(Citem
) = N_With_Clause
15109 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15111 Set_Elaborate_Present
(Citem
, True);
15112 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15114 -- With the pragma present, elaboration calls on
15115 -- subprograms from the named unit need no further
15116 -- checks, as long as the pragma appears in the current
15117 -- compilation unit. If the pragma appears in some unit
15118 -- in the context, there might still be a need for an
15119 -- Elaborate_All_Desirable from the current compilation
15120 -- to the named unit, so we keep the check enabled. This
15121 -- does not apply in SPARK mode, where we allow pragma
15122 -- Elaborate, but we don't trust it to be right so we
15123 -- will still insist on the Elaborate_All.
15125 if Legacy_Elaboration_Checks
15126 and then In_Extended_Main_Source_Unit
(N
)
15127 and then SPARK_Mode
/= On
15129 Set_Suppress_Elaboration_Warnings
15130 (Entity
(Name
(Citem
)));
15141 ("argument of pragma% is not withed unit", Arg
);
15148 -------------------
15149 -- Elaborate_All --
15150 -------------------
15152 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15154 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15159 Check_Ada_83_Warning
;
15161 -- Pragma must be in context items list of a compilation unit
15163 if not Is_In_Context_Clause
then
15167 -- Must be at least one argument
15169 if Arg_Count
= 0 then
15170 Error_Pragma
("pragma% requires at least one argument");
15173 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15174 -- have to appear at the end of the context clause, but may
15175 -- appear mixed in with other items, even in Ada 83 mode.
15177 -- Final check: the arguments must all be units mentioned in
15178 -- a with clause in the same context clause. Note that we
15179 -- already checked (in Par.Prag) that all the arguments are
15180 -- either identifiers or selected components.
15183 Outr
: while Present
(Arg
) loop
15184 Citem
:= First
(List_Containing
(N
));
15185 Innr
: while Citem
/= N
loop
15186 if Nkind
(Citem
) = N_With_Clause
15187 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15189 Set_Elaborate_All_Present
(Citem
, True);
15190 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15192 -- Suppress warnings and elaboration checks on the named
15193 -- unit if the pragma is in the current compilation, as
15194 -- for pragma Elaborate.
15196 if Legacy_Elaboration_Checks
15197 and then In_Extended_Main_Source_Unit
(N
)
15199 Set_Suppress_Elaboration_Warnings
15200 (Entity
(Name
(Citem
)));
15210 Set_Error_Posted
(N
);
15212 ("argument of pragma% is not withed unit", Arg
);
15219 --------------------
15220 -- Elaborate_Body --
15221 --------------------
15223 -- pragma Elaborate_Body [( library_unit_NAME )];
15225 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15226 Cunit_Node
: Node_Id
;
15227 Cunit_Ent
: Entity_Id
;
15230 Check_Ada_83_Warning
;
15231 Check_Valid_Library_Unit_Pragma
;
15233 if Nkind
(N
) = N_Null_Statement
then
15237 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15238 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15240 -- A pragma that applies to a Ghost entity becomes Ghost for the
15241 -- purposes of legality checks and removal of ignored Ghost code.
15243 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15245 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15248 Error_Pragma
("pragma% must refer to a spec, not a body");
15250 Set_Body_Required
(Cunit_Node
);
15251 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15253 -- If we are in dynamic elaboration mode, then we suppress
15254 -- elaboration warnings for the unit, since it is definitely
15255 -- fine NOT to do dynamic checks at the first level (and such
15256 -- checks will be suppressed because no elaboration boolean
15257 -- is created for Elaborate_Body packages).
15259 -- But in the static model of elaboration, Elaborate_Body is
15260 -- definitely NOT good enough to ensure elaboration safety on
15261 -- its own, since the body may WITH other units that are not
15262 -- safe from an elaboration point of view, so a client must
15263 -- still do an Elaborate_All on such units.
15265 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15266 -- Elaborate_Body always suppressed elab warnings.
15268 if Legacy_Elaboration_Checks
15269 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15271 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15274 end Elaborate_Body
;
15276 ------------------------
15277 -- Elaboration_Checks --
15278 ------------------------
15280 -- pragma Elaboration_Checks (Static | Dynamic);
15282 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
15283 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
15284 -- Emit an error if the current context list already contains
15285 -- a previous Elaboration_Checks pragma. This routine raises
15286 -- Pragma_Exit if a duplicate is found.
15288 procedure Ignore_Elaboration_Checks_Pragma
;
15289 -- Warn that the effects of the pragma are ignored. This routine
15290 -- raises Pragma_Exit.
15292 -----------------------------------------------
15293 -- Check_Duplicate_Elaboration_Checks_Pragma --
15294 -----------------------------------------------
15296 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
15301 while Present
(Item
) loop
15302 if Nkind
(Item
) = N_Pragma
15303 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
15313 end Check_Duplicate_Elaboration_Checks_Pragma
;
15315 --------------------------------------
15316 -- Ignore_Elaboration_Checks_Pragma --
15317 --------------------------------------
15319 procedure Ignore_Elaboration_Checks_Pragma
is
15321 Error_Msg_Name_1
:= Pname
;
15322 Error_Msg_N
("??effects of pragma % are ignored", N
);
15324 ("\place pragma on initial declaration of library unit", N
);
15327 end Ignore_Elaboration_Checks_Pragma
;
15331 Context
: constant Node_Id
:= Parent
(N
);
15334 -- Start of processing for Elaboration_Checks
15338 Check_Arg_Count
(1);
15339 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
15341 -- The pragma appears in a configuration file
15343 if No
(Context
) then
15344 Check_Valid_Configuration_Pragma
;
15345 Check_Duplicate_Elaboration_Checks_Pragma
;
15347 -- The pragma acts as a configuration pragma in a compilation unit
15349 -- pragma Elaboration_Checks (...);
15350 -- package Pack is ...;
15352 elsif Nkind
(Context
) = N_Compilation_Unit
15353 and then List_Containing
(N
) = Context_Items
(Context
)
15355 Check_Valid_Configuration_Pragma
;
15356 Check_Duplicate_Elaboration_Checks_Pragma
;
15358 Unt
:= Unit
(Context
);
15360 -- The pragma must appear on the initial declaration of a unit.
15361 -- If this is not the case, warn that the effects of the pragma
15364 if Nkind
(Unt
) = N_Package_Body
then
15365 Ignore_Elaboration_Checks_Pragma
;
15367 -- Check the Acts_As_Spec flag of the compilation units itself
15368 -- to determine whether the subprogram body completes since it
15369 -- has not been analyzed yet. This is safe because compilation
15370 -- units are not overloadable.
15372 elsif Nkind
(Unt
) = N_Subprogram_Body
15373 and then not Acts_As_Spec
(Context
)
15375 Ignore_Elaboration_Checks_Pragma
;
15377 elsif Nkind
(Unt
) = N_Subunit
then
15378 Ignore_Elaboration_Checks_Pragma
;
15381 -- Otherwise the pragma does not appear at the configuration level
15388 -- At this point the pragma is not a duplicate, and appears in the
15389 -- proper context. Set the elaboration model in effect.
15391 Dynamic_Elaboration_Checks
:=
15392 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
15393 end Elaboration_Checks
;
15399 -- pragma Eliminate (
15400 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15401 -- [Entity =>] IDENTIFIER |
15402 -- SELECTED_COMPONENT |
15404 -- [, Source_Location => SOURCE_TRACE]);
15406 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15407 -- SOURCE_TRACE ::= STRING_LITERAL
15409 when Pragma_Eliminate
=> Eliminate
: declare
15410 Args
: Args_List
(1 .. 5);
15411 Names
: constant Name_List
(1 .. 5) := (
15414 Name_Parameter_Types
,
15416 Name_Source_Location
);
15418 -- Note : Parameter_Types and Result_Type are leftovers from
15419 -- prior implementations of the pragma. They are not generated
15420 -- by the gnatelim tool, and play no role in selecting which
15421 -- of a set of overloaded names is chosen for elimination.
15423 Unit_Name
: Node_Id
renames Args
(1);
15424 Entity
: Node_Id
renames Args
(2);
15425 Parameter_Types
: Node_Id
renames Args
(3);
15426 Result_Type
: Node_Id
renames Args
(4);
15427 Source_Location
: Node_Id
renames Args
(5);
15431 Check_Valid_Configuration_Pragma
;
15432 Gather_Associations
(Names
, Args
);
15434 if No
(Unit_Name
) then
15435 Error_Pragma
("missing Unit_Name argument for pragma%");
15439 and then (Present
(Parameter_Types
)
15441 Present
(Result_Type
)
15443 Present
(Source_Location
))
15445 Error_Pragma
("missing Entity argument for pragma%");
15448 if (Present
(Parameter_Types
)
15450 Present
(Result_Type
))
15452 Present
(Source_Location
)
15455 ("parameter profile and source location cannot be used "
15456 & "together in pragma%");
15459 Process_Eliminate_Pragma
15468 -----------------------------------
15469 -- Enable_Atomic_Synchronization --
15470 -----------------------------------
15472 -- pragma Enable_Atomic_Synchronization [(Entity)];
15474 when Pragma_Enable_Atomic_Synchronization
=>
15476 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
15483 -- [ Convention =>] convention_IDENTIFIER,
15484 -- [ Entity =>] LOCAL_NAME
15485 -- [, [External_Name =>] static_string_EXPRESSION ]
15486 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15488 when Pragma_Export
=> Export
: declare
15490 Def_Id
: Entity_Id
;
15492 pragma Warnings
(Off
, C
);
15495 Check_Ada_83_Warning
;
15499 Name_External_Name
,
15502 Check_At_Least_N_Arguments
(2);
15503 Check_At_Most_N_Arguments
(4);
15505 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15506 -- pragma Export (Entity, "external name");
15508 if Relaxed_RM_Semantics
15509 and then Arg_Count
= 2
15510 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
15513 Def_Id
:= Get_Pragma_Arg
(Arg1
);
15516 if not Is_Entity_Name
(Def_Id
) then
15517 Error_Pragma_Arg
("entity name required", Arg1
);
15520 Def_Id
:= Entity
(Def_Id
);
15521 Set_Exported
(Def_Id
, Arg1
);
15524 Process_Convention
(C
, Def_Id
);
15526 -- A pragma that applies to a Ghost entity becomes Ghost for
15527 -- the purposes of legality checks and removal of ignored Ghost
15530 Mark_Ghost_Pragma
(N
, Def_Id
);
15532 if Ekind
(Def_Id
) /= E_Constant
then
15533 Note_Possible_Modification
15534 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15537 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
15538 Set_Exported
(Def_Id
, Arg2
);
15541 -- If the entity is a deferred constant, propagate the information
15542 -- to the full view, because gigi elaborates the full view only.
15544 if Ekind
(Def_Id
) = E_Constant
15545 and then Present
(Full_View
(Def_Id
))
15548 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
15550 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
15551 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
15552 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
15557 ---------------------
15558 -- Export_Function --
15559 ---------------------
15561 -- pragma Export_Function (
15562 -- [Internal =>] LOCAL_NAME
15563 -- [, [External =>] EXTERNAL_SYMBOL]
15564 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15565 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15566 -- [, [Mechanism =>] MECHANISM]
15567 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15569 -- EXTERNAL_SYMBOL ::=
15571 -- | static_string_EXPRESSION
15573 -- PARAMETER_TYPES ::=
15575 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15577 -- TYPE_DESIGNATOR ::=
15579 -- | subtype_Name ' Access
15583 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15585 -- MECHANISM_ASSOCIATION ::=
15586 -- [formal_parameter_NAME =>] MECHANISM_NAME
15588 -- MECHANISM_NAME ::=
15592 when Pragma_Export_Function
=> Export_Function
: declare
15593 Args
: Args_List
(1 .. 6);
15594 Names
: constant Name_List
(1 .. 6) := (
15597 Name_Parameter_Types
,
15600 Name_Result_Mechanism
);
15602 Internal
: Node_Id
renames Args
(1);
15603 External
: Node_Id
renames Args
(2);
15604 Parameter_Types
: Node_Id
renames Args
(3);
15605 Result_Type
: Node_Id
renames Args
(4);
15606 Mechanism
: Node_Id
renames Args
(5);
15607 Result_Mechanism
: Node_Id
renames Args
(6);
15611 Gather_Associations
(Names
, Args
);
15612 Process_Extended_Import_Export_Subprogram_Pragma
(
15613 Arg_Internal
=> Internal
,
15614 Arg_External
=> External
,
15615 Arg_Parameter_Types
=> Parameter_Types
,
15616 Arg_Result_Type
=> Result_Type
,
15617 Arg_Mechanism
=> Mechanism
,
15618 Arg_Result_Mechanism
=> Result_Mechanism
);
15619 end Export_Function
;
15621 -------------------
15622 -- Export_Object --
15623 -------------------
15625 -- pragma Export_Object (
15626 -- [Internal =>] LOCAL_NAME
15627 -- [, [External =>] EXTERNAL_SYMBOL]
15628 -- [, [Size =>] EXTERNAL_SYMBOL]);
15630 -- EXTERNAL_SYMBOL ::=
15632 -- | static_string_EXPRESSION
15634 -- PARAMETER_TYPES ::=
15636 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15638 -- TYPE_DESIGNATOR ::=
15640 -- | subtype_Name ' Access
15644 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15646 -- MECHANISM_ASSOCIATION ::=
15647 -- [formal_parameter_NAME =>] MECHANISM_NAME
15649 -- MECHANISM_NAME ::=
15653 when Pragma_Export_Object
=> Export_Object
: declare
15654 Args
: Args_List
(1 .. 3);
15655 Names
: constant Name_List
(1 .. 3) := (
15660 Internal
: Node_Id
renames Args
(1);
15661 External
: Node_Id
renames Args
(2);
15662 Size
: Node_Id
renames Args
(3);
15666 Gather_Associations
(Names
, Args
);
15667 Process_Extended_Import_Export_Object_Pragma
(
15668 Arg_Internal
=> Internal
,
15669 Arg_External
=> External
,
15673 ----------------------
15674 -- Export_Procedure --
15675 ----------------------
15677 -- pragma Export_Procedure (
15678 -- [Internal =>] LOCAL_NAME
15679 -- [, [External =>] EXTERNAL_SYMBOL]
15680 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15681 -- [, [Mechanism =>] MECHANISM]);
15683 -- EXTERNAL_SYMBOL ::=
15685 -- | static_string_EXPRESSION
15687 -- PARAMETER_TYPES ::=
15689 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15691 -- TYPE_DESIGNATOR ::=
15693 -- | subtype_Name ' Access
15697 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15699 -- MECHANISM_ASSOCIATION ::=
15700 -- [formal_parameter_NAME =>] MECHANISM_NAME
15702 -- MECHANISM_NAME ::=
15706 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15707 Args
: Args_List
(1 .. 4);
15708 Names
: constant Name_List
(1 .. 4) := (
15711 Name_Parameter_Types
,
15714 Internal
: Node_Id
renames Args
(1);
15715 External
: Node_Id
renames Args
(2);
15716 Parameter_Types
: Node_Id
renames Args
(3);
15717 Mechanism
: Node_Id
renames Args
(4);
15721 Gather_Associations
(Names
, Args
);
15722 Process_Extended_Import_Export_Subprogram_Pragma
(
15723 Arg_Internal
=> Internal
,
15724 Arg_External
=> External
,
15725 Arg_Parameter_Types
=> Parameter_Types
,
15726 Arg_Mechanism
=> Mechanism
);
15727 end Export_Procedure
;
15733 -- pragma Export_Value (
15734 -- [Value =>] static_integer_EXPRESSION,
15735 -- [Link_Name =>] static_string_EXPRESSION);
15737 when Pragma_Export_Value
=>
15739 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15740 Check_Arg_Count
(2);
15742 Check_Optional_Identifier
(Arg1
, Name_Value
);
15743 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15745 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15746 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15748 -----------------------------
15749 -- Export_Valued_Procedure --
15750 -----------------------------
15752 -- pragma Export_Valued_Procedure (
15753 -- [Internal =>] LOCAL_NAME
15754 -- [, [External =>] EXTERNAL_SYMBOL,]
15755 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15756 -- [, [Mechanism =>] MECHANISM]);
15758 -- EXTERNAL_SYMBOL ::=
15760 -- | static_string_EXPRESSION
15762 -- PARAMETER_TYPES ::=
15764 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15766 -- TYPE_DESIGNATOR ::=
15768 -- | subtype_Name ' Access
15772 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15774 -- MECHANISM_ASSOCIATION ::=
15775 -- [formal_parameter_NAME =>] MECHANISM_NAME
15777 -- MECHANISM_NAME ::=
15781 when Pragma_Export_Valued_Procedure
=>
15782 Export_Valued_Procedure
: declare
15783 Args
: Args_List
(1 .. 4);
15784 Names
: constant Name_List
(1 .. 4) := (
15787 Name_Parameter_Types
,
15790 Internal
: Node_Id
renames Args
(1);
15791 External
: Node_Id
renames Args
(2);
15792 Parameter_Types
: Node_Id
renames Args
(3);
15793 Mechanism
: Node_Id
renames Args
(4);
15797 Gather_Associations
(Names
, Args
);
15798 Process_Extended_Import_Export_Subprogram_Pragma
(
15799 Arg_Internal
=> Internal
,
15800 Arg_External
=> External
,
15801 Arg_Parameter_Types
=> Parameter_Types
,
15802 Arg_Mechanism
=> Mechanism
);
15803 end Export_Valued_Procedure
;
15805 -------------------
15806 -- Extend_System --
15807 -------------------
15809 -- pragma Extend_System ([Name =>] Identifier);
15811 when Pragma_Extend_System
=>
15813 Check_Valid_Configuration_Pragma
;
15814 Check_Arg_Count
(1);
15815 Check_Optional_Identifier
(Arg1
, Name_Name
);
15816 Check_Arg_Is_Identifier
(Arg1
);
15818 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15821 and then Name_Buffer
(1 .. 4) = "aux_"
15823 if Present
(System_Extend_Pragma_Arg
) then
15824 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15825 Chars
(Expression
(System_Extend_Pragma_Arg
))
15829 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15830 Error_Pragma
("pragma% conflicts with that #");
15834 System_Extend_Pragma_Arg
:= Arg1
;
15836 if not GNAT_Mode
then
15837 System_Extend_Unit
:= Arg1
;
15841 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15844 ------------------------
15845 -- Extensions_Allowed --
15846 ------------------------
15848 -- pragma Extensions_Allowed (ON | OFF);
15850 when Pragma_Extensions_Allowed
=>
15852 Check_Arg_Count
(1);
15853 Check_No_Identifiers
;
15854 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15856 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15857 Extensions_Allowed
:= True;
15858 Ada_Version
:= Ada_Version_Type
'Last;
15861 Extensions_Allowed
:= False;
15862 Ada_Version
:= Ada_Version_Explicit
;
15863 Ada_Version_Pragma
:= Empty
;
15866 ------------------------
15867 -- Extensions_Visible --
15868 ------------------------
15870 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15872 -- Characteristics:
15874 -- * Analysis - The annotation is fully analyzed immediately upon
15875 -- elaboration as its expression must be static.
15877 -- * Expansion - None.
15879 -- * Template - The annotation utilizes the generic template of the
15880 -- related subprogram [body] when it is:
15882 -- aspect on subprogram declaration
15883 -- aspect on stand-alone subprogram body
15884 -- pragma on stand-alone subprogram body
15886 -- The annotation must prepare its own template when it is:
15888 -- pragma on subprogram declaration
15890 -- * Globals - Capture of global references must occur after full
15893 -- * Instance - The annotation is instantiated automatically when
15894 -- the related generic subprogram [body] is instantiated except for
15895 -- the "pragma on subprogram declaration" case. In that scenario
15896 -- the annotation must instantiate itself.
15898 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15899 Formal
: Entity_Id
;
15900 Has_OK_Formal
: Boolean := False;
15901 Spec_Id
: Entity_Id
;
15902 Subp_Decl
: Node_Id
;
15906 Check_No_Identifiers
;
15907 Check_At_Most_N_Arguments
(1);
15910 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15912 -- Abstract subprogram declaration
15914 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15917 -- Generic subprogram declaration
15919 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15922 -- Body acts as spec
15924 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15925 and then No
(Corresponding_Spec
(Subp_Decl
))
15929 -- Body stub acts as spec
15931 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15932 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15936 -- Subprogram declaration
15938 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15941 -- Otherwise the pragma is associated with an illegal construct
15944 Error_Pragma
("pragma % must apply to a subprogram");
15948 -- Mark the pragma as Ghost if the related subprogram is also
15949 -- Ghost. This also ensures that any expansion performed further
15950 -- below will produce Ghost nodes.
15952 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15953 Mark_Ghost_Pragma
(N
, Spec_Id
);
15955 -- Chain the pragma on the contract for completeness
15957 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15959 -- The legality checks of pragma Extension_Visible are affected
15960 -- by the SPARK mode in effect. Analyze all pragmas in specific
15963 Analyze_If_Present
(Pragma_SPARK_Mode
);
15965 -- Examine the formals of the related subprogram
15967 Formal
:= First_Formal
(Spec_Id
);
15968 while Present
(Formal
) loop
15970 -- At least one of the formals is of a specific tagged type,
15971 -- the pragma is legal.
15973 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15974 Has_OK_Formal
:= True;
15977 -- A generic subprogram with at least one formal of a private
15978 -- type ensures the legality of the pragma because the actual
15979 -- may be specifically tagged. Note that this is verified by
15980 -- the check above at instantiation time.
15982 elsif Is_Private_Type
(Etype
(Formal
))
15983 and then Is_Generic_Type
(Etype
(Formal
))
15985 Has_OK_Formal
:= True;
15989 Next_Formal
(Formal
);
15992 if not Has_OK_Formal
then
15993 Error_Msg_Name_1
:= Pname
;
15994 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15996 ("\subprogram & lacks parameter of specific tagged or "
15997 & "generic private type", N
, Spec_Id
);
16002 -- Analyze the Boolean expression (if any)
16004 if Present
(Arg1
) then
16005 Check_Static_Boolean_Expression
16006 (Expression
(Get_Argument
(N
, Spec_Id
)));
16008 end Extensions_Visible
;
16014 -- pragma External (
16015 -- [ Convention =>] convention_IDENTIFIER,
16016 -- [ Entity =>] LOCAL_NAME
16017 -- [, [External_Name =>] static_string_EXPRESSION ]
16018 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16020 when Pragma_External
=> External
: declare
16023 pragma Warnings
(Off
, C
);
16030 Name_External_Name
,
16032 Check_At_Least_N_Arguments
(2);
16033 Check_At_Most_N_Arguments
(4);
16034 Process_Convention
(C
, E
);
16036 -- A pragma that applies to a Ghost entity becomes Ghost for the
16037 -- purposes of legality checks and removal of ignored Ghost code.
16039 Mark_Ghost_Pragma
(N
, E
);
16041 Note_Possible_Modification
16042 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16043 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16044 Set_Exported
(E
, Arg2
);
16047 --------------------------
16048 -- External_Name_Casing --
16049 --------------------------
16051 -- pragma External_Name_Casing (
16052 -- UPPERCASE | LOWERCASE
16053 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16055 when Pragma_External_Name_Casing
=>
16057 Check_No_Identifiers
;
16059 if Arg_Count
= 2 then
16060 Check_Arg_Is_One_Of
16061 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16063 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16065 Opt
.External_Name_Exp_Casing
:= As_Is
;
16067 when Name_Uppercase
=>
16068 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16070 when Name_Lowercase
=>
16071 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16078 Check_Arg_Count
(1);
16081 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16083 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16084 when Name_Uppercase
=>
16085 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16087 when Name_Lowercase
=>
16088 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16098 -- pragma Fast_Math;
16100 when Pragma_Fast_Math
=>
16102 Check_No_Identifiers
;
16103 Check_Valid_Configuration_Pragma
;
16106 --------------------------
16107 -- Favor_Top_Level --
16108 --------------------------
16110 -- pragma Favor_Top_Level (type_NAME);
16112 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16117 Check_No_Identifiers
;
16118 Check_Arg_Count
(1);
16119 Check_Arg_Is_Local_Name
(Arg1
);
16120 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16122 -- A pragma that applies to a Ghost entity becomes Ghost for the
16123 -- purposes of legality checks and removal of ignored Ghost code.
16125 Mark_Ghost_Pragma
(N
, Typ
);
16127 -- If it's an access-to-subprogram type (in particular, not a
16128 -- subtype), set the flag on that type.
16130 if Is_Access_Subprogram_Type
(Typ
) then
16131 Set_Can_Use_Internal_Rep
(Typ
, False);
16133 -- Otherwise it's an error (name denotes the wrong sort of entity)
16137 ("access-to-subprogram type expected",
16138 Get_Pragma_Arg
(Arg1
));
16140 end Favor_Top_Level
;
16142 ---------------------------
16143 -- Finalize_Storage_Only --
16144 ---------------------------
16146 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16148 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16149 Assoc
: constant Node_Id
:= Arg1
;
16150 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16155 Check_No_Identifiers
;
16156 Check_Arg_Count
(1);
16157 Check_Arg_Is_Local_Name
(Arg1
);
16159 Find_Type
(Type_Id
);
16160 Typ
:= Entity
(Type_Id
);
16163 or else Rep_Item_Too_Early
(Typ
, N
)
16167 Typ
:= Underlying_Type
(Typ
);
16170 if not Is_Controlled
(Typ
) then
16171 Error_Pragma
("pragma% must specify controlled type");
16174 Check_First_Subtype
(Arg1
);
16176 if Finalize_Storage_Only
(Typ
) then
16177 Error_Pragma
("duplicate pragma%, only one allowed");
16179 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16180 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16182 end Finalize_Storage
;
16188 -- pragma Ghost [ (boolean_EXPRESSION) ];
16190 when Pragma_Ghost
=> Ghost
: declare
16194 Orig_Stmt
: Node_Id
;
16195 Prev_Id
: Entity_Id
;
16200 Check_No_Identifiers
;
16201 Check_At_Most_N_Arguments
(1);
16205 while Present
(Stmt
) loop
16207 -- Skip prior pragmas, but check for duplicates
16209 if Nkind
(Stmt
) = N_Pragma
then
16210 if Pragma_Name
(Stmt
) = Pname
then
16217 -- Task unit declared without a definition cannot be subject to
16218 -- pragma Ghost (SPARK RM 6.9(19)).
16220 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16221 N_Task_Type_Declaration
)
16223 Error_Pragma
("pragma % cannot apply to a task type");
16226 -- Skip internally generated code
16228 elsif not Comes_From_Source
(Stmt
) then
16229 Orig_Stmt
:= Original_Node
(Stmt
);
16231 -- When pragma Ghost applies to an untagged derivation, the
16232 -- derivation is transformed into a [sub]type declaration.
16234 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16235 N_Subtype_Declaration
)
16236 and then Comes_From_Source
(Orig_Stmt
)
16237 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16238 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16239 N_Derived_Type_Definition
16241 Id
:= Defining_Entity
(Stmt
);
16244 -- When pragma Ghost applies to an object declaration which
16245 -- is initialized by means of a function call that returns
16246 -- on the secondary stack, the object declaration becomes a
16249 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16250 and then Comes_From_Source
(Orig_Stmt
)
16251 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16253 Id
:= Defining_Entity
(Stmt
);
16256 -- When pragma Ghost applies to an expression function, the
16257 -- expression function is transformed into a subprogram.
16259 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16260 and then Comes_From_Source
(Orig_Stmt
)
16261 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16263 Id
:= Defining_Entity
(Stmt
);
16267 -- The pragma applies to a legal construct, stop the traversal
16269 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16270 N_Full_Type_Declaration
,
16271 N_Generic_Subprogram_Declaration
,
16272 N_Object_Declaration
,
16273 N_Private_Extension_Declaration
,
16274 N_Private_Type_Declaration
,
16275 N_Subprogram_Declaration
,
16276 N_Subtype_Declaration
)
16278 Id
:= Defining_Entity
(Stmt
);
16281 -- The pragma does not apply to a legal construct, issue an
16282 -- error and stop the analysis.
16286 ("pragma % must apply to an object, package, subprogram "
16291 Stmt
:= Prev
(Stmt
);
16294 Context
:= Parent
(N
);
16296 -- Handle compilation units
16298 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
16299 Context
:= Unit
(Parent
(Context
));
16302 -- Protected and task types cannot be subject to pragma Ghost
16303 -- (SPARK RM 6.9(19)).
16305 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
16307 Error_Pragma
("pragma % cannot apply to a protected type");
16310 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
16311 Error_Pragma
("pragma % cannot apply to a task type");
16317 -- When pragma Ghost is associated with a [generic] package, it
16318 -- appears in the visible declarations.
16320 if Nkind
(Context
) = N_Package_Specification
16321 and then Present
(Visible_Declarations
(Context
))
16322 and then List_Containing
(N
) = Visible_Declarations
(Context
)
16324 Id
:= Defining_Entity
(Context
);
16326 -- Pragma Ghost applies to a stand-alone subprogram body
16328 elsif Nkind
(Context
) = N_Subprogram_Body
16329 and then No
(Corresponding_Spec
(Context
))
16331 Id
:= Defining_Entity
(Context
);
16333 -- Pragma Ghost applies to a subprogram declaration that acts
16334 -- as a compilation unit.
16336 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
16337 Id
:= Defining_Entity
(Context
);
16339 -- Pragma Ghost applies to a generic subprogram
16341 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
16342 Id
:= Defining_Entity
(Specification
(Context
));
16348 ("pragma % must apply to an object, package, subprogram or "
16353 -- Handle completions of types and constants that are subject to
16356 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
16357 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
16359 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
16360 Error_Msg_Name_1
:= Pname
;
16362 -- The full declaration of a deferred constant cannot be
16363 -- subject to pragma Ghost unless the deferred declaration
16364 -- is also Ghost (SPARK RM 6.9(9)).
16366 if Ekind
(Prev_Id
) = E_Constant
then
16367 Error_Msg_Name_1
:= Pname
;
16368 Error_Msg_NE
(Fix_Error
16369 ("pragma % must apply to declaration of deferred "
16370 & "constant &"), N
, Id
);
16373 -- Pragma Ghost may appear on the full view of an incomplete
16374 -- type because the incomplete declaration lacks aspects and
16375 -- cannot be subject to pragma Ghost.
16377 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
16380 -- The full declaration of a type cannot be subject to
16381 -- pragma Ghost unless the partial view is also Ghost
16382 -- (SPARK RM 6.9(9)).
16385 Error_Msg_NE
(Fix_Error
16386 ("pragma % must apply to partial view of type &"),
16392 -- A synchronized object cannot be subject to pragma Ghost
16393 -- (SPARK RM 6.9(19)).
16395 elsif Ekind
(Id
) = E_Variable
then
16396 if Is_Protected_Type
(Etype
(Id
)) then
16397 Error_Pragma
("pragma % cannot apply to a protected object");
16400 elsif Is_Task_Type
(Etype
(Id
)) then
16401 Error_Pragma
("pragma % cannot apply to a task object");
16406 -- Analyze the Boolean expression (if any)
16408 if Present
(Arg1
) then
16409 Expr
:= Get_Pragma_Arg
(Arg1
);
16411 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
16413 if Is_OK_Static_Expression
(Expr
) then
16415 -- "Ghostness" cannot be turned off once enabled within a
16416 -- region (SPARK RM 6.9(6)).
16418 if Is_False
(Expr_Value
(Expr
))
16419 and then Ghost_Mode
> None
16422 ("pragma % with value False cannot appear in enabled "
16427 -- Otherwie the expression is not static
16431 ("expression of pragma % must be static", Expr
);
16436 Set_Is_Ghost_Entity
(Id
);
16443 -- pragma Global (GLOBAL_SPECIFICATION);
16445 -- GLOBAL_SPECIFICATION ::=
16448 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16450 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16452 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16453 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16454 -- GLOBAL_ITEM ::= NAME
16456 -- Characteristics:
16458 -- * Analysis - The annotation undergoes initial checks to verify
16459 -- the legal placement and context. Secondary checks fully analyze
16460 -- the dependency clauses in:
16462 -- Analyze_Global_In_Decl_Part
16464 -- * Expansion - None.
16466 -- * Template - The annotation utilizes the generic template of the
16467 -- related subprogram [body] when it is:
16469 -- aspect on subprogram declaration
16470 -- aspect on stand-alone subprogram body
16471 -- pragma on stand-alone subprogram body
16473 -- The annotation must prepare its own template when it is:
16475 -- pragma on subprogram declaration
16477 -- * Globals - Capture of global references must occur after full
16480 -- * Instance - The annotation is instantiated automatically when
16481 -- the related generic subprogram [body] is instantiated except for
16482 -- the "pragma on subprogram declaration" case. In that scenario
16483 -- the annotation must instantiate itself.
16485 when Pragma_Global
=> Global
: declare
16487 Spec_Id
: Entity_Id
;
16488 Subp_Decl
: Node_Id
;
16491 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16495 -- Chain the pragma on the contract for further processing by
16496 -- Analyze_Global_In_Decl_Part.
16498 Add_Contract_Item
(N
, Spec_Id
);
16500 -- Fully analyze the pragma when it appears inside an entry
16501 -- or subprogram body because it cannot benefit from forward
16504 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
16506 N_Subprogram_Body_Stub
)
16508 -- The legality checks of pragmas Depends and Global are
16509 -- affected by the SPARK mode in effect and the volatility
16510 -- of the context. In addition these two pragmas are subject
16511 -- to an inherent order:
16516 -- Analyze all these pragmas in the order outlined above
16518 Analyze_If_Present
(Pragma_SPARK_Mode
);
16519 Analyze_If_Present
(Pragma_Volatile_Function
);
16520 Analyze_Global_In_Decl_Part
(N
);
16521 Analyze_If_Present
(Pragma_Depends
);
16530 -- pragma Ident (static_string_EXPRESSION)
16532 -- Note: pragma Comment shares this processing. Pragma Ident is
16533 -- identical in effect to pragma Commment.
16535 when Pragma_Comment
16543 Check_Arg_Count
(1);
16544 Check_No_Identifiers
;
16545 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16548 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
16555 GP
:= Parent
(Parent
(N
));
16557 if Nkind_In
(GP
, N_Package_Declaration
,
16558 N_Generic_Package_Declaration
)
16563 -- If we have a compilation unit, then record the ident value,
16564 -- checking for improper duplication.
16566 if Nkind
(GP
) = N_Compilation_Unit
then
16567 CS
:= Ident_String
(Current_Sem_Unit
);
16569 if Present
(CS
) then
16571 -- If we have multiple instances, concatenate them, but
16572 -- not in ASIS, where we want the original tree.
16574 if not ASIS_Mode
then
16575 Start_String
(Strval
(CS
));
16576 Store_String_Char
(' ');
16577 Store_String_Chars
(Strval
(Str
));
16578 Set_Strval
(CS
, End_String
);
16582 Set_Ident_String
(Current_Sem_Unit
, Str
);
16585 -- For subunits, we just ignore the Ident, since in GNAT these
16586 -- are not separate object files, and hence not separate units
16587 -- in the unit table.
16589 elsif Nkind
(GP
) = N_Subunit
then
16595 -------------------
16596 -- Ignore_Pragma --
16597 -------------------
16599 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16601 -- Entirely handled in the parser, nothing to do here
16603 when Pragma_Ignore_Pragma
=>
16606 ----------------------------
16607 -- Implementation_Defined --
16608 ----------------------------
16610 -- pragma Implementation_Defined (LOCAL_NAME);
16612 -- Marks previously declared entity as implementation defined. For
16613 -- an overloaded entity, applies to the most recent homonym.
16615 -- pragma Implementation_Defined;
16617 -- The form with no arguments appears anywhere within a scope, most
16618 -- typically a package spec, and indicates that all entities that are
16619 -- defined within the package spec are Implementation_Defined.
16621 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
16626 Check_No_Identifiers
;
16628 -- Form with no arguments
16630 if Arg_Count
= 0 then
16631 Set_Is_Implementation_Defined
(Current_Scope
);
16633 -- Form with one argument
16636 Check_Arg_Count
(1);
16637 Check_Arg_Is_Local_Name
(Arg1
);
16638 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
16639 Set_Is_Implementation_Defined
(Ent
);
16641 end Implementation_Defined
;
16647 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16649 -- IMPLEMENTATION_KIND ::=
16650 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16652 -- "By_Any" and "Optional" are treated as synonyms in order to
16653 -- support Ada 2012 aspect Synchronization.
16655 when Pragma_Implemented
=> Implemented
: declare
16656 Proc_Id
: Entity_Id
;
16661 Check_Arg_Count
(2);
16662 Check_No_Identifiers
;
16663 Check_Arg_Is_Identifier
(Arg1
);
16664 Check_Arg_Is_Local_Name
(Arg1
);
16665 Check_Arg_Is_One_Of
(Arg2
,
16668 Name_By_Protected_Procedure
,
16671 -- Extract the name of the local procedure
16673 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16675 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16676 -- primitive procedure of a synchronized tagged type.
16678 if Ekind
(Proc_Id
) = E_Procedure
16679 and then Is_Primitive
(Proc_Id
)
16680 and then Present
(First_Formal
(Proc_Id
))
16682 Typ
:= Etype
(First_Formal
(Proc_Id
));
16684 if Is_Tagged_Type
(Typ
)
16687 -- Check for a protected, a synchronized or a task interface
16689 ((Is_Interface
(Typ
)
16690 and then Is_Synchronized_Interface
(Typ
))
16692 -- Check for a protected type or a task type that implements
16696 (Is_Concurrent_Record_Type
(Typ
)
16697 and then Present
(Interfaces
(Typ
)))
16699 -- In analysis-only mode, examine original protected type
16702 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16703 and then Present
(Interface_List
(Parent
(Typ
))))
16705 -- Check for a private record extension with keyword
16709 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16710 E_Record_Subtype_With_Private
)
16711 and then Synchronized_Present
(Parent
(Typ
))))
16716 ("controlling formal must be of synchronized tagged type",
16721 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16722 -- By_Protected_Procedure to the primitive procedure of a task
16725 if Chars
(Arg2
) = Name_By_Protected_Procedure
16726 and then Is_Interface
(Typ
)
16727 and then Is_Task_Interface
(Typ
)
16730 ("implementation kind By_Protected_Procedure cannot be "
16731 & "applied to a task interface primitive", Arg2
);
16735 -- Procedures declared inside a protected type must be accepted
16737 elsif Ekind
(Proc_Id
) = E_Procedure
16738 and then Is_Protected_Type
(Scope
(Proc_Id
))
16742 -- The first argument is not a primitive procedure
16746 ("pragma % must be applied to a primitive procedure", Arg1
);
16750 Record_Rep_Item
(Proc_Id
, N
);
16753 ----------------------
16754 -- Implicit_Packing --
16755 ----------------------
16757 -- pragma Implicit_Packing;
16759 when Pragma_Implicit_Packing
=>
16761 Check_Arg_Count
(0);
16762 Implicit_Packing
:= True;
16769 -- [Convention =>] convention_IDENTIFIER,
16770 -- [Entity =>] LOCAL_NAME
16771 -- [, [External_Name =>] static_string_EXPRESSION ]
16772 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16774 when Pragma_Import
=>
16775 Check_Ada_83_Warning
;
16779 Name_External_Name
,
16782 Check_At_Least_N_Arguments
(2);
16783 Check_At_Most_N_Arguments
(4);
16784 Process_Import_Or_Interface
;
16786 ---------------------
16787 -- Import_Function --
16788 ---------------------
16790 -- pragma Import_Function (
16791 -- [Internal =>] LOCAL_NAME,
16792 -- [, [External =>] EXTERNAL_SYMBOL]
16793 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16794 -- [, [Result_Type =>] SUBTYPE_MARK]
16795 -- [, [Mechanism =>] MECHANISM]
16796 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16798 -- EXTERNAL_SYMBOL ::=
16800 -- | static_string_EXPRESSION
16802 -- PARAMETER_TYPES ::=
16804 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16806 -- TYPE_DESIGNATOR ::=
16808 -- | subtype_Name ' Access
16812 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16814 -- MECHANISM_ASSOCIATION ::=
16815 -- [formal_parameter_NAME =>] MECHANISM_NAME
16817 -- MECHANISM_NAME ::=
16821 when Pragma_Import_Function
=> Import_Function
: declare
16822 Args
: Args_List
(1 .. 6);
16823 Names
: constant Name_List
(1 .. 6) := (
16826 Name_Parameter_Types
,
16829 Name_Result_Mechanism
);
16831 Internal
: Node_Id
renames Args
(1);
16832 External
: Node_Id
renames Args
(2);
16833 Parameter_Types
: Node_Id
renames Args
(3);
16834 Result_Type
: Node_Id
renames Args
(4);
16835 Mechanism
: Node_Id
renames Args
(5);
16836 Result_Mechanism
: Node_Id
renames Args
(6);
16840 Gather_Associations
(Names
, Args
);
16841 Process_Extended_Import_Export_Subprogram_Pragma
(
16842 Arg_Internal
=> Internal
,
16843 Arg_External
=> External
,
16844 Arg_Parameter_Types
=> Parameter_Types
,
16845 Arg_Result_Type
=> Result_Type
,
16846 Arg_Mechanism
=> Mechanism
,
16847 Arg_Result_Mechanism
=> Result_Mechanism
);
16848 end Import_Function
;
16850 -------------------
16851 -- Import_Object --
16852 -------------------
16854 -- pragma Import_Object (
16855 -- [Internal =>] LOCAL_NAME
16856 -- [, [External =>] EXTERNAL_SYMBOL]
16857 -- [, [Size =>] EXTERNAL_SYMBOL]);
16859 -- EXTERNAL_SYMBOL ::=
16861 -- | static_string_EXPRESSION
16863 when Pragma_Import_Object
=> Import_Object
: declare
16864 Args
: Args_List
(1 .. 3);
16865 Names
: constant Name_List
(1 .. 3) := (
16870 Internal
: Node_Id
renames Args
(1);
16871 External
: Node_Id
renames Args
(2);
16872 Size
: Node_Id
renames Args
(3);
16876 Gather_Associations
(Names
, Args
);
16877 Process_Extended_Import_Export_Object_Pragma
(
16878 Arg_Internal
=> Internal
,
16879 Arg_External
=> External
,
16883 ----------------------
16884 -- Import_Procedure --
16885 ----------------------
16887 -- pragma Import_Procedure (
16888 -- [Internal =>] LOCAL_NAME
16889 -- [, [External =>] EXTERNAL_SYMBOL]
16890 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16891 -- [, [Mechanism =>] MECHANISM]);
16893 -- EXTERNAL_SYMBOL ::=
16895 -- | static_string_EXPRESSION
16897 -- PARAMETER_TYPES ::=
16899 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16901 -- TYPE_DESIGNATOR ::=
16903 -- | subtype_Name ' Access
16907 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16909 -- MECHANISM_ASSOCIATION ::=
16910 -- [formal_parameter_NAME =>] MECHANISM_NAME
16912 -- MECHANISM_NAME ::=
16916 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16917 Args
: Args_List
(1 .. 4);
16918 Names
: constant Name_List
(1 .. 4) := (
16921 Name_Parameter_Types
,
16924 Internal
: Node_Id
renames Args
(1);
16925 External
: Node_Id
renames Args
(2);
16926 Parameter_Types
: Node_Id
renames Args
(3);
16927 Mechanism
: Node_Id
renames Args
(4);
16931 Gather_Associations
(Names
, Args
);
16932 Process_Extended_Import_Export_Subprogram_Pragma
(
16933 Arg_Internal
=> Internal
,
16934 Arg_External
=> External
,
16935 Arg_Parameter_Types
=> Parameter_Types
,
16936 Arg_Mechanism
=> Mechanism
);
16937 end Import_Procedure
;
16939 -----------------------------
16940 -- Import_Valued_Procedure --
16941 -----------------------------
16943 -- pragma Import_Valued_Procedure (
16944 -- [Internal =>] LOCAL_NAME
16945 -- [, [External =>] EXTERNAL_SYMBOL]
16946 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16947 -- [, [Mechanism =>] MECHANISM]);
16949 -- EXTERNAL_SYMBOL ::=
16951 -- | static_string_EXPRESSION
16953 -- PARAMETER_TYPES ::=
16955 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16957 -- TYPE_DESIGNATOR ::=
16959 -- | subtype_Name ' Access
16963 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16965 -- MECHANISM_ASSOCIATION ::=
16966 -- [formal_parameter_NAME =>] MECHANISM_NAME
16968 -- MECHANISM_NAME ::=
16972 when Pragma_Import_Valued_Procedure
=>
16973 Import_Valued_Procedure
: declare
16974 Args
: Args_List
(1 .. 4);
16975 Names
: constant Name_List
(1 .. 4) := (
16978 Name_Parameter_Types
,
16981 Internal
: Node_Id
renames Args
(1);
16982 External
: Node_Id
renames Args
(2);
16983 Parameter_Types
: Node_Id
renames Args
(3);
16984 Mechanism
: Node_Id
renames Args
(4);
16988 Gather_Associations
(Names
, Args
);
16989 Process_Extended_Import_Export_Subprogram_Pragma
(
16990 Arg_Internal
=> Internal
,
16991 Arg_External
=> External
,
16992 Arg_Parameter_Types
=> Parameter_Types
,
16993 Arg_Mechanism
=> Mechanism
);
16994 end Import_Valued_Procedure
;
17000 -- pragma Independent (LOCAL_NAME);
17002 when Pragma_Independent
=>
17003 Process_Atomic_Independent_Shared_Volatile
;
17005 ----------------------------
17006 -- Independent_Components --
17007 ----------------------------
17009 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17011 when Pragma_Independent_Components
=> Independent_Components
: declare
17019 Check_Ada_83_Warning
;
17021 Check_No_Identifiers
;
17022 Check_Arg_Count
(1);
17023 Check_Arg_Is_Local_Name
(Arg1
);
17024 E_Id
:= Get_Pragma_Arg
(Arg1
);
17026 if Etype
(E_Id
) = Any_Type
then
17030 E
:= Entity
(E_Id
);
17032 -- A record type with a self-referential component of anonymous
17033 -- access type is given an incomplete view in order to handle the
17036 -- type Rec is record
17037 -- Self : access Rec;
17043 -- type Ptr is access Rec;
17044 -- type Rec is record
17048 -- Since the incomplete view is now the initial view of the type,
17049 -- the argument of the pragma will reference the incomplete view,
17050 -- but this view is illegal according to the semantics of the
17053 -- Obtain the full view of an internally-generated incomplete type
17054 -- only. This way an attempt to associate the pragma with a source
17055 -- incomplete type is still caught.
17057 if Ekind
(E
) = E_Incomplete_Type
17058 and then not Comes_From_Source
(E
)
17059 and then Present
(Full_View
(E
))
17061 E
:= Full_View
(E
);
17064 -- A pragma that applies to a Ghost entity becomes Ghost for the
17065 -- purposes of legality checks and removal of ignored Ghost code.
17067 Mark_Ghost_Pragma
(N
, E
);
17069 -- Check duplicate before we chain ourselves
17071 Check_Duplicate_Pragma
(E
);
17073 -- Check appropriate entity
17075 if Rep_Item_Too_Early
(E
, N
)
17077 Rep_Item_Too_Late
(E
, N
)
17082 D
:= Declaration_Node
(E
);
17085 -- The flag is set on the base type, or on the object
17087 if K
= N_Full_Type_Declaration
17088 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17090 Set_Has_Independent_Components
(Base_Type
(E
));
17091 Record_Independence_Check
(N
, Base_Type
(E
));
17093 -- For record type, set all components independent
17095 if Is_Record_Type
(E
) then
17096 C
:= First_Component
(E
);
17097 while Present
(C
) loop
17098 Set_Is_Independent
(C
);
17099 Next_Component
(C
);
17103 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17104 and then Nkind
(D
) = N_Object_Declaration
17105 and then Nkind
(Object_Definition
(D
)) =
17106 N_Constrained_Array_Definition
17108 Set_Has_Independent_Components
(E
);
17109 Record_Independence_Check
(N
, E
);
17112 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17114 end Independent_Components
;
17116 -----------------------
17117 -- Initial_Condition --
17118 -----------------------
17120 -- pragma Initial_Condition (boolean_EXPRESSION);
17122 -- Characteristics:
17124 -- * Analysis - The annotation undergoes initial checks to verify
17125 -- the legal placement and context. Secondary checks preanalyze the
17128 -- Analyze_Initial_Condition_In_Decl_Part
17130 -- * Expansion - The annotation is expanded during the expansion of
17131 -- the package body whose declaration is subject to the annotation
17134 -- Expand_Pragma_Initial_Condition
17136 -- * Template - The annotation utilizes the generic template of the
17137 -- related package declaration.
17139 -- * Globals - Capture of global references must occur after full
17142 -- * Instance - The annotation is instantiated automatically when
17143 -- the related generic package is instantiated.
17145 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17146 Pack_Decl
: Node_Id
;
17147 Pack_Id
: Entity_Id
;
17151 Check_No_Identifiers
;
17152 Check_Arg_Count
(1);
17154 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17156 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17157 N_Package_Declaration
)
17163 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17165 -- A pragma that applies to a Ghost entity becomes Ghost for the
17166 -- purposes of legality checks and removal of ignored Ghost code.
17168 Mark_Ghost_Pragma
(N
, Pack_Id
);
17170 -- Chain the pragma on the contract for further processing by
17171 -- Analyze_Initial_Condition_In_Decl_Part.
17173 Add_Contract_Item
(N
, Pack_Id
);
17175 -- The legality checks of pragmas Abstract_State, Initializes, and
17176 -- Initial_Condition are affected by the SPARK mode in effect. In
17177 -- addition, these three pragmas are subject to an inherent order:
17179 -- 1) Abstract_State
17181 -- 3) Initial_Condition
17183 -- Analyze all these pragmas in the order outlined above
17185 Analyze_If_Present
(Pragma_SPARK_Mode
);
17186 Analyze_If_Present
(Pragma_Abstract_State
);
17187 Analyze_If_Present
(Pragma_Initializes
);
17188 end Initial_Condition
;
17190 ------------------------
17191 -- Initialize_Scalars --
17192 ------------------------
17194 -- pragma Initialize_Scalars
17195 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17197 -- TYPE_VALUE_PAIR ::=
17198 -- SCALAR_TYPE => static_EXPRESSION
17204 -- | Long_Long_Flat
17214 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
17215 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
17216 -- This collection holds the individual pairs which specify the
17217 -- invalid values of their respective scalar types.
17219 procedure Analyze_Float_Value
17220 (Scal_Typ
: Float_Scalar_Id
;
17221 Val_Expr
: Node_Id
);
17222 -- Analyze a type value pair associated with float type Scal_Typ
17223 -- and expression Val_Expr.
17225 procedure Analyze_Integer_Value
17226 (Scal_Typ
: Integer_Scalar_Id
;
17227 Val_Expr
: Node_Id
);
17228 -- Analyze a type value pair associated with integer type Scal_Typ
17229 -- and expression Val_Expr.
17231 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
17232 -- Analyze type value pair Pair
17234 -------------------------
17235 -- Analyze_Float_Value --
17236 -------------------------
17238 procedure Analyze_Float_Value
17239 (Scal_Typ
: Float_Scalar_Id
;
17240 Val_Expr
: Node_Id
)
17243 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
17245 if Is_OK_Static_Expression
(Val_Expr
) then
17246 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
17249 Error_Msg_Name_1
:= Scal_Typ
;
17250 Error_Msg_N
("value for type % must be static", Val_Expr
);
17252 end Analyze_Float_Value
;
17254 ---------------------------
17255 -- Analyze_Integer_Value --
17256 ---------------------------
17258 procedure Analyze_Integer_Value
17259 (Scal_Typ
: Integer_Scalar_Id
;
17260 Val_Expr
: Node_Id
)
17263 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
17265 if Is_OK_Static_Expression
(Val_Expr
) then
17266 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
17269 Error_Msg_Name_1
:= Scal_Typ
;
17270 Error_Msg_N
("value for type % must be static", Val_Expr
);
17272 end Analyze_Integer_Value
;
17274 -----------------------------
17275 -- Analyze_Type_Value_Pair --
17276 -----------------------------
17278 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
17279 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
17280 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
17281 Prev_Pair
: Node_Id
;
17284 if Scal_Typ
in Scalar_Id
then
17285 Prev_Pair
:= Seen
(Scal_Typ
);
17287 -- Prevent multiple attempts to set a value for a scalar
17290 if Present
(Prev_Pair
) then
17291 Error_Msg_Name_1
:= Scal_Typ
;
17293 ("cannot specify multiple invalid values for type %",
17296 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
17297 Error_Msg_N
("previous value set #", Pair
);
17299 -- Ignore the effects of the pair, but do not halt the
17300 -- analysis of the pragma altogether.
17304 -- Otherwise capture the first pair for this scalar type
17307 Seen
(Scal_Typ
) := Pair
;
17310 if Scal_Typ
in Float_Scalar_Id
then
17311 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
17313 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
17314 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
17317 -- Otherwise the scalar family is illegal
17320 Error_Msg_Name_1
:= Pname
;
17322 ("argument of pragma % must denote valid scalar family",
17325 end Analyze_Type_Value_Pair
;
17329 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
17332 -- Start of processing for Do_Initialize_Scalars
17336 Check_Valid_Configuration_Pragma
;
17337 Check_Restriction
(No_Initialize_Scalars
, N
);
17339 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17342 if Restriction_Active
(No_Initialize_Scalars
) then
17345 -- Initialize_Scalars creates false positives in CodePeer, and
17346 -- incorrect negative results in GNATprove mode, so ignore this
17347 -- pragma in these modes.
17349 elsif CodePeer_Mode
or GNATprove_Mode
then
17352 -- Otherwise analyze the pragma
17355 if Present
(Pairs
) then
17357 -- Install Standard in order to provide access to primitive
17358 -- types in case the expressions contain attributes such as
17361 Push_Scope
(Standard_Standard
);
17363 Pair
:= First
(Pairs
);
17364 while Present
(Pair
) loop
17365 Analyze_Type_Value_Pair
(Pair
);
17374 Init_Or_Norm_Scalars
:= True;
17375 Initialize_Scalars
:= True;
17377 end Do_Initialize_Scalars
;
17383 -- pragma Initializes (INITIALIZATION_LIST);
17385 -- INITIALIZATION_LIST ::=
17387 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17389 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17394 -- | (INPUT {, INPUT})
17398 -- Characteristics:
17400 -- * Analysis - The annotation undergoes initial checks to verify
17401 -- the legal placement and context. Secondary checks preanalyze the
17404 -- Analyze_Initializes_In_Decl_Part
17406 -- * Expansion - None.
17408 -- * Template - The annotation utilizes the generic template of the
17409 -- related package declaration.
17411 -- * Globals - Capture of global references must occur after full
17414 -- * Instance - The annotation is instantiated automatically when
17415 -- the related generic package is instantiated.
17417 when Pragma_Initializes
=> Initializes
: declare
17418 Pack_Decl
: Node_Id
;
17419 Pack_Id
: Entity_Id
;
17423 Check_No_Identifiers
;
17424 Check_Arg_Count
(1);
17426 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17428 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17429 N_Package_Declaration
)
17435 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17437 -- A pragma that applies to a Ghost entity becomes Ghost for the
17438 -- purposes of legality checks and removal of ignored Ghost code.
17440 Mark_Ghost_Pragma
(N
, Pack_Id
);
17441 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
17443 -- Chain the pragma on the contract for further processing by
17444 -- Analyze_Initializes_In_Decl_Part.
17446 Add_Contract_Item
(N
, Pack_Id
);
17448 -- The legality checks of pragmas Abstract_State, Initializes, and
17449 -- Initial_Condition are affected by the SPARK mode in effect. In
17450 -- addition, these three pragmas are subject to an inherent order:
17452 -- 1) Abstract_State
17454 -- 3) Initial_Condition
17456 -- Analyze all these pragmas in the order outlined above
17458 Analyze_If_Present
(Pragma_SPARK_Mode
);
17459 Analyze_If_Present
(Pragma_Abstract_State
);
17460 Analyze_If_Present
(Pragma_Initial_Condition
);
17467 -- pragma Inline ( NAME {, NAME} );
17469 when Pragma_Inline
=>
17471 -- Pragma always active unless in GNATprove mode. It is disabled
17472 -- in GNATprove mode because frontend inlining is applied
17473 -- independently of pragmas Inline and Inline_Always for
17474 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17477 if not GNATprove_Mode
then
17479 -- Inline status is Enabled if option -gnatn is specified.
17480 -- However this status determines only the value of the
17481 -- Is_Inlined flag on the subprogram and does not prevent
17482 -- the pragma itself from being recorded for later use,
17483 -- in particular for a later modification of Is_Inlined
17484 -- independently of the -gnatn option.
17486 -- In other words, if -gnatn is specified for a unit, then
17487 -- all Inline pragmas processed for the compilation of this
17488 -- unit, including those in the spec of other units, are
17489 -- activated, so subprograms will be inlined across units.
17491 -- If -gnatn is not specified, no Inline pragma is activated
17492 -- here, which means that subprograms will not be inlined
17493 -- across units. The Is_Inlined flag will nevertheless be
17494 -- set later when bodies are analyzed, so subprograms will
17495 -- be inlined within the unit.
17497 if Inline_Active
then
17498 Process_Inline
(Enabled
);
17500 Process_Inline
(Disabled
);
17504 -------------------
17505 -- Inline_Always --
17506 -------------------
17508 -- pragma Inline_Always ( NAME {, NAME} );
17510 when Pragma_Inline_Always
=>
17513 -- Pragma always active unless in CodePeer mode or GNATprove
17514 -- mode. It is disabled in CodePeer mode because inlining is
17515 -- not helpful, and enabling it caused walk order issues. It
17516 -- is disabled in GNATprove mode because frontend inlining is
17517 -- applied independently of pragmas Inline and Inline_Always for
17518 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17521 if not CodePeer_Mode
and not GNATprove_Mode
then
17522 Process_Inline
(Enabled
);
17525 --------------------
17526 -- Inline_Generic --
17527 --------------------
17529 -- pragma Inline_Generic (NAME {, NAME});
17531 when Pragma_Inline_Generic
=>
17533 Process_Generic_List
;
17535 ----------------------
17536 -- Inspection_Point --
17537 ----------------------
17539 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17541 when Pragma_Inspection_Point
=> Inspection_Point
: declare
17548 if Arg_Count
> 0 then
17551 Exp
:= Get_Pragma_Arg
(Arg
);
17554 if not Is_Entity_Name
(Exp
)
17555 or else not Is_Object
(Entity
(Exp
))
17557 Error_Pragma_Arg
("object name required", Arg
);
17561 exit when No
(Arg
);
17564 end Inspection_Point
;
17570 -- pragma Interface (
17571 -- [ Convention =>] convention_IDENTIFIER,
17572 -- [ Entity =>] LOCAL_NAME
17573 -- [, [External_Name =>] static_string_EXPRESSION ]
17574 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17576 when Pragma_Interface
=>
17581 Name_External_Name
,
17583 Check_At_Least_N_Arguments
(2);
17584 Check_At_Most_N_Arguments
(4);
17585 Process_Import_Or_Interface
;
17587 -- In Ada 2005, the permission to use Interface (a reserved word)
17588 -- as a pragma name is considered an obsolescent feature, and this
17589 -- pragma was already obsolescent in Ada 95.
17591 if Ada_Version
>= Ada_95
then
17593 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
17595 if Warn_On_Obsolescent_Feature
then
17597 ("pragma Interface is an obsolescent feature?j?", N
);
17599 ("|use pragma Import instead?j?", N
);
17603 --------------------
17604 -- Interface_Name --
17605 --------------------
17607 -- pragma Interface_Name (
17608 -- [ Entity =>] LOCAL_NAME
17609 -- [,[External_Name =>] static_string_EXPRESSION ]
17610 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17612 when Pragma_Interface_Name
=> Interface_Name
: declare
17614 Def_Id
: Entity_Id
;
17615 Hom_Id
: Entity_Id
;
17621 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
17622 Check_At_Least_N_Arguments
(2);
17623 Check_At_Most_N_Arguments
(3);
17624 Id
:= Get_Pragma_Arg
(Arg1
);
17627 -- This is obsolete from Ada 95 on, but it is an implementation
17628 -- defined pragma, so we do not consider that it violates the
17629 -- restriction (No_Obsolescent_Features).
17631 if Ada_Version
>= Ada_95
then
17632 if Warn_On_Obsolescent_Feature
then
17634 ("pragma Interface_Name is an obsolescent feature?j?", N
);
17636 ("|use pragma Import instead?j?", N
);
17640 if not Is_Entity_Name
(Id
) then
17642 ("first argument for pragma% must be entity name", Arg1
);
17643 elsif Etype
(Id
) = Any_Type
then
17646 Def_Id
:= Entity
(Id
);
17649 -- Special DEC-compatible processing for the object case, forces
17650 -- object to be imported.
17652 if Ekind
(Def_Id
) = E_Variable
then
17653 Kill_Size_Check_Code
(Def_Id
);
17654 Note_Possible_Modification
(Id
, Sure
=> False);
17656 -- Initialization is not allowed for imported variable
17658 if Present
(Expression
(Parent
(Def_Id
)))
17659 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
17661 Error_Msg_Sloc
:= Sloc
(Def_Id
);
17663 ("no initialization allowed for declaration of& #",
17667 -- For compatibility, support VADS usage of providing both
17668 -- pragmas Interface and Interface_Name to obtain the effect
17669 -- of a single Import pragma.
17671 if Is_Imported
(Def_Id
)
17672 and then Present
(First_Rep_Item
(Def_Id
))
17673 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
17674 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
17679 Set_Imported
(Def_Id
);
17682 Set_Is_Public
(Def_Id
);
17683 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17686 -- Otherwise must be subprogram
17688 elsif not Is_Subprogram
(Def_Id
) then
17690 ("argument of pragma% is not subprogram", Arg1
);
17693 Check_At_Most_N_Arguments
(3);
17697 -- Loop through homonyms
17700 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
17702 if Is_Imported
(Def_Id
) then
17703 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17707 exit when From_Aspect_Specification
(N
);
17708 Hom_Id
:= Homonym
(Hom_Id
);
17710 exit when No
(Hom_Id
)
17711 or else Scope
(Hom_Id
) /= Current_Scope
;
17716 ("argument of pragma% is not imported subprogram",
17720 end Interface_Name
;
17722 -----------------------
17723 -- Interrupt_Handler --
17724 -----------------------
17726 -- pragma Interrupt_Handler (handler_NAME);
17728 when Pragma_Interrupt_Handler
=>
17729 Check_Ada_83_Warning
;
17730 Check_Arg_Count
(1);
17731 Check_No_Identifiers
;
17733 if No_Run_Time_Mode
then
17734 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
17736 Check_Interrupt_Or_Attach_Handler
;
17737 Process_Interrupt_Or_Attach_Handler
;
17740 ------------------------
17741 -- Interrupt_Priority --
17742 ------------------------
17744 -- pragma Interrupt_Priority [(EXPRESSION)];
17746 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
17747 P
: constant Node_Id
:= Parent
(N
);
17752 Check_Ada_83_Warning
;
17754 if Arg_Count
/= 0 then
17755 Arg
:= Get_Pragma_Arg
(Arg1
);
17756 Check_Arg_Count
(1);
17757 Check_No_Identifiers
;
17759 -- The expression must be analyzed in the special manner
17760 -- described in "Handling of Default and Per-Object
17761 -- Expressions" in sem.ads.
17763 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
17766 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
17771 Ent
:= Defining_Identifier
(Parent
(P
));
17773 -- Check duplicate pragma before we chain the pragma in the Rep
17774 -- Item chain of Ent.
17776 Check_Duplicate_Pragma
(Ent
);
17777 Record_Rep_Item
(Ent
, N
);
17779 -- Check the No_Task_At_Interrupt_Priority restriction
17781 if Nkind
(P
) = N_Task_Definition
then
17782 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
17785 end Interrupt_Priority
;
17787 ---------------------
17788 -- Interrupt_State --
17789 ---------------------
17791 -- pragma Interrupt_State (
17792 -- [Name =>] INTERRUPT_ID,
17793 -- [State =>] INTERRUPT_STATE);
17795 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
17796 -- INTERRUPT_STATE => System | Runtime | User
17798 -- Note: if the interrupt id is given as an identifier, then it must
17799 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
17800 -- given as a static integer expression which must be in the range of
17801 -- Ada.Interrupts.Interrupt_ID.
17803 when Pragma_Interrupt_State
=> Interrupt_State
: declare
17804 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
17805 -- This is the entity Ada.Interrupts.Interrupt_ID;
17807 State_Type
: Character;
17808 -- Set to 's'/'r'/'u' for System/Runtime/User
17811 -- Index to entry in Interrupt_States table
17814 -- Value of interrupt
17816 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17817 -- The first argument to the pragma
17819 Int_Ent
: Entity_Id
;
17820 -- Interrupt entity in Ada.Interrupts.Names
17824 Check_Arg_Order
((Name_Name
, Name_State
));
17825 Check_Arg_Count
(2);
17827 Check_Optional_Identifier
(Arg1
, Name_Name
);
17828 Check_Optional_Identifier
(Arg2
, Name_State
);
17829 Check_Arg_Is_Identifier
(Arg2
);
17831 -- First argument is identifier
17833 if Nkind
(Arg1X
) = N_Identifier
then
17835 -- Search list of names in Ada.Interrupts.Names
17837 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
17839 if No
(Int_Ent
) then
17840 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
17842 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
17843 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
17847 Next_Entity
(Int_Ent
);
17850 -- First argument is not an identifier, so it must be a static
17851 -- expression of type Ada.Interrupts.Interrupt_ID.
17854 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
17855 Int_Val
:= Expr_Value
(Arg1X
);
17857 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
17859 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17862 ("value not in range of type "
17863 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17869 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17870 when Name_Runtime
=> State_Type
:= 'r';
17871 when Name_System
=> State_Type
:= 's';
17872 when Name_User
=> State_Type
:= 'u';
17875 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17878 -- Check if entry is already stored
17880 IST_Num
:= Interrupt_States
.First
;
17882 -- If entry not found, add it
17884 if IST_Num
> Interrupt_States
.Last
then
17885 Interrupt_States
.Append
17886 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17887 Interrupt_State
=> State_Type
,
17888 Pragma_Loc
=> Loc
));
17891 -- Case of entry for the same entry
17893 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17896 -- If state matches, done, no need to make redundant entry
17899 State_Type
= Interrupt_States
.Table
(IST_Num
).
17902 -- Otherwise if state does not match, error
17905 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17907 ("state conflicts with that given #", Arg2
);
17911 IST_Num
:= IST_Num
+ 1;
17913 end Interrupt_State
;
17919 -- pragma Invariant
17920 -- ([Entity =>] type_LOCAL_NAME,
17921 -- [Check =>] EXPRESSION
17922 -- [,[Message =>] String_Expression]);
17924 when Pragma_Invariant
=> Invariant
: declare
17931 Check_At_Least_N_Arguments
(2);
17932 Check_At_Most_N_Arguments
(3);
17933 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17934 Check_Optional_Identifier
(Arg2
, Name_Check
);
17936 if Arg_Count
= 3 then
17937 Check_Optional_Identifier
(Arg3
, Name_Message
);
17938 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17941 Check_Arg_Is_Local_Name
(Arg1
);
17943 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17944 Find_Type
(Typ_Arg
);
17945 Typ
:= Entity
(Typ_Arg
);
17947 -- Nothing to do of the related type is erroneous in some way
17949 if Typ
= Any_Type
then
17952 -- AI12-0041: Invariants are allowed in interface types
17954 elsif Is_Interface
(Typ
) then
17957 -- An invariant must apply to a private type, or appear in the
17958 -- private part of a package spec and apply to a completion.
17959 -- a class-wide invariant can only appear on a private declaration
17960 -- or private extension, not a completion.
17962 -- A [class-wide] invariant may be associated a [limited] private
17963 -- type or a private extension.
17965 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17967 E_Record_Type_With_Private
)
17971 -- A non-class-wide invariant may be associated with the full view
17972 -- of a [limited] private type or a private extension.
17974 elsif Has_Private_Declaration
(Typ
)
17975 and then not Class_Present
(N
)
17979 -- A class-wide invariant may appear on the partial view only
17981 elsif Class_Present
(N
) then
17983 ("pragma % only allowed for private type", Arg1
);
17986 -- A regular invariant may appear on both views
17990 ("pragma % only allowed for private type or corresponding "
17991 & "full view", Arg1
);
17995 -- An invariant associated with an abstract type (this includes
17996 -- interfaces) must be class-wide.
17998 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18000 ("pragma % not allowed for abstract type", Arg1
);
18004 -- A pragma that applies to a Ghost entity becomes Ghost for the
18005 -- purposes of legality checks and removal of ignored Ghost code.
18007 Mark_Ghost_Pragma
(N
, Typ
);
18009 -- The pragma defines a type-specific invariant, the type is said
18010 -- to have invariants of its "own".
18012 Set_Has_Own_Invariants
(Typ
);
18014 -- If the invariant is class-wide, then it can be inherited by
18015 -- derived or interface implementing types. The type is said to
18016 -- have "inheritable" invariants.
18018 if Class_Present
(N
) then
18019 Set_Has_Inheritable_Invariants
(Typ
);
18022 -- Chain the pragma on to the rep item chain, for processing when
18023 -- the type is frozen.
18025 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18027 -- Create the declaration of the invariant procedure that will
18028 -- verify the invariant at run time. Interfaces are treated as the
18029 -- partial view of a private type in order to achieve uniformity
18030 -- with the general case. As a result, an interface receives only
18031 -- a "partial" invariant procedure, which is never called.
18033 Build_Invariant_Procedure_Declaration
18035 Partial_Invariant
=> Is_Interface
(Typ
));
18042 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18044 when Pragma_Keep_Names
=> Keep_Names
: declare
18049 Check_Arg_Count
(1);
18050 Check_Optional_Identifier
(Arg1
, Name_On
);
18051 Check_Arg_Is_Local_Name
(Arg1
);
18053 Arg
:= Get_Pragma_Arg
(Arg1
);
18056 if Etype
(Arg
) = Any_Type
then
18060 if not Is_Entity_Name
(Arg
)
18061 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18064 ("pragma% requires a local enumeration type", Arg1
);
18067 Set_Discard_Names
(Entity
(Arg
), False);
18074 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18076 when Pragma_License
=>
18079 -- Do not analyze pragma any further in CodePeer mode, to avoid
18080 -- extraneous errors in this implementation-dependent pragma,
18081 -- which has a different profile on other compilers.
18083 if CodePeer_Mode
then
18087 Check_Arg_Count
(1);
18088 Check_No_Identifiers
;
18089 Check_Valid_Configuration_Pragma
;
18090 Check_Arg_Is_Identifier
(Arg1
);
18093 Sind
: constant Source_File_Index
:=
18094 Source_Index
(Current_Sem_Unit
);
18097 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18099 Set_License
(Sind
, GPL
);
18101 when Name_Modified_GPL
=>
18102 Set_License
(Sind
, Modified_GPL
);
18104 when Name_Restricted
=>
18105 Set_License
(Sind
, Restricted
);
18107 when Name_Unrestricted
=>
18108 Set_License
(Sind
, Unrestricted
);
18111 Error_Pragma_Arg
("invalid license name", Arg1
);
18119 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18121 when Pragma_Link_With
=> Link_With
: declare
18127 if Operating_Mode
= Generate_Code
18128 and then In_Extended_Main_Source_Unit
(N
)
18130 Check_At_Least_N_Arguments
(1);
18131 Check_No_Identifiers
;
18132 Check_Is_In_Decl_Part_Or_Package_Spec
;
18133 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18137 while Present
(Arg
) loop
18138 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18140 -- Store argument, converting sequences of spaces to a
18141 -- single null character (this is one of the differences
18142 -- in processing between Link_With and Linker_Options).
18144 Arg_Store
: declare
18145 C
: constant Char_Code
:= Get_Char_Code
(' ');
18146 S
: constant String_Id
:=
18147 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18148 L
: constant Nat
:= String_Length
(S
);
18151 procedure Skip_Spaces
;
18152 -- Advance F past any spaces
18158 procedure Skip_Spaces
is
18160 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18165 -- Start of processing for Arg_Store
18168 Skip_Spaces
; -- skip leading spaces
18170 -- Loop through characters, changing any embedded
18171 -- sequence of spaces to a single null character (this
18172 -- is how Link_With/Linker_Options differ)
18175 if Get_String_Char
(S
, F
) = C
then
18178 Store_String_Char
(ASCII
.NUL
);
18181 Store_String_Char
(Get_String_Char
(S
, F
));
18189 if Present
(Arg
) then
18190 Store_String_Char
(ASCII
.NUL
);
18194 Store_Linker_Option_String
(End_String
);
18202 -- pragma Linker_Alias (
18203 -- [Entity =>] LOCAL_NAME
18204 -- [Target =>] static_string_EXPRESSION);
18206 when Pragma_Linker_Alias
=>
18208 Check_Arg_Order
((Name_Entity
, Name_Target
));
18209 Check_Arg_Count
(2);
18210 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18211 Check_Optional_Identifier
(Arg2
, Name_Target
);
18212 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18213 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18215 -- The only processing required is to link this item on to the
18216 -- list of rep items for the given entity. This is accomplished
18217 -- by the call to Rep_Item_Too_Late (when no error is detected
18218 -- and False is returned).
18220 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
18223 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18226 ------------------------
18227 -- Linker_Constructor --
18228 ------------------------
18230 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18232 -- Code is shared with Linker_Destructor
18234 -----------------------
18235 -- Linker_Destructor --
18236 -----------------------
18238 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18240 when Pragma_Linker_Constructor
18241 | Pragma_Linker_Destructor
18243 Linker_Constructor
: declare
18249 Check_Arg_Count
(1);
18250 Check_No_Identifiers
;
18251 Check_Arg_Is_Local_Name
(Arg1
);
18252 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
18254 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
18256 if not Is_Library_Level_Entity
(Proc
) then
18258 ("argument for pragma% must be library level entity", Arg1
);
18261 -- The only processing required is to link this item on to the
18262 -- list of rep items for the given entity. This is accomplished
18263 -- by the call to Rep_Item_Too_Late (when no error is detected
18264 -- and False is returned).
18266 if Rep_Item_Too_Late
(Proc
, N
) then
18269 Set_Has_Gigi_Rep_Item
(Proc
);
18271 end Linker_Constructor
;
18273 --------------------
18274 -- Linker_Options --
18275 --------------------
18277 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18279 when Pragma_Linker_Options
=> Linker_Options
: declare
18283 Check_Ada_83_Warning
;
18284 Check_No_Identifiers
;
18285 Check_Arg_Count
(1);
18286 Check_Is_In_Decl_Part_Or_Package_Spec
;
18287 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18288 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
18291 while Present
(Arg
) loop
18292 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18293 Store_String_Char
(ASCII
.NUL
);
18295 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
18299 if Operating_Mode
= Generate_Code
18300 and then In_Extended_Main_Source_Unit
(N
)
18302 Store_Linker_Option_String
(End_String
);
18304 end Linker_Options
;
18306 --------------------
18307 -- Linker_Section --
18308 --------------------
18310 -- pragma Linker_Section (
18311 -- [Entity =>] LOCAL_NAME
18312 -- [Section =>] static_string_EXPRESSION);
18314 when Pragma_Linker_Section
=> Linker_Section
: declare
18319 Ghost_Error_Posted
: Boolean := False;
18320 -- Flag set when an error concerning the illegal mix of Ghost and
18321 -- non-Ghost subprograms is emitted.
18323 Ghost_Id
: Entity_Id
:= Empty
;
18324 -- The entity of the first Ghost subprogram encountered while
18325 -- processing the arguments of the pragma.
18329 Check_Arg_Order
((Name_Entity
, Name_Section
));
18330 Check_Arg_Count
(2);
18331 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18332 Check_Optional_Identifier
(Arg2
, Name_Section
);
18333 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18334 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18336 -- Check kind of entity
18338 Arg
:= Get_Pragma_Arg
(Arg1
);
18339 Ent
:= Entity
(Arg
);
18341 case Ekind
(Ent
) is
18343 -- Objects (constants and variables) and types. For these cases
18344 -- all we need to do is to set the Linker_Section_pragma field,
18345 -- checking that we do not have a duplicate.
18351 LPE
:= Linker_Section_Pragma
(Ent
);
18353 if Present
(LPE
) then
18354 Error_Msg_Sloc
:= Sloc
(LPE
);
18356 ("Linker_Section already specified for &#", Arg1
, Ent
);
18359 Set_Linker_Section_Pragma
(Ent
, N
);
18361 -- A pragma that applies to a Ghost entity becomes Ghost for
18362 -- the purposes of legality checks and removal of ignored
18365 Mark_Ghost_Pragma
(N
, Ent
);
18369 when Subprogram_Kind
=>
18371 -- Aspect case, entity already set
18373 if From_Aspect_Specification
(N
) then
18374 Set_Linker_Section_Pragma
18375 (Entity
(Corresponding_Aspect
(N
)), N
);
18377 -- Pragma case, we must climb the homonym chain, but skip
18378 -- any for which the linker section is already set.
18382 if No
(Linker_Section_Pragma
(Ent
)) then
18383 Set_Linker_Section_Pragma
(Ent
, N
);
18385 -- A pragma that applies to a Ghost entity becomes
18386 -- Ghost for the purposes of legality checks and
18387 -- removal of ignored Ghost code.
18389 Mark_Ghost_Pragma
(N
, Ent
);
18391 -- Capture the entity of the first Ghost subprogram
18392 -- being processed for error detection purposes.
18394 if Is_Ghost_Entity
(Ent
) then
18395 if No
(Ghost_Id
) then
18399 -- Otherwise the subprogram is non-Ghost. It is
18400 -- illegal to mix references to Ghost and non-Ghost
18401 -- entities (SPARK RM 6.9).
18403 elsif Present
(Ghost_Id
)
18404 and then not Ghost_Error_Posted
18406 Ghost_Error_Posted
:= True;
18408 Error_Msg_Name_1
:= Pname
;
18410 ("pragma % cannot mention ghost and "
18411 & "non-ghost subprograms", N
);
18413 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18415 ("\& # declared as ghost", N
, Ghost_Id
);
18417 Error_Msg_Sloc
:= Sloc
(Ent
);
18419 ("\& # declared as non-ghost", N
, Ent
);
18423 Ent
:= Homonym
(Ent
);
18425 or else Scope
(Ent
) /= Current_Scope
;
18429 -- All other cases are illegal
18433 ("pragma% applies only to objects, subprograms, and types",
18436 end Linker_Section
;
18442 -- pragma List (On | Off)
18444 -- There is nothing to do here, since we did all the processing for
18445 -- this pragma in Par.Prag (so that it works properly even in syntax
18448 when Pragma_List
=>
18455 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18457 when Pragma_Lock_Free
=> Lock_Free
: declare
18458 P
: constant Node_Id
:= Parent
(N
);
18464 Check_No_Identifiers
;
18465 Check_At_Most_N_Arguments
(1);
18467 -- Protected definition case
18469 if Nkind
(P
) = N_Protected_Definition
then
18470 Ent
:= Defining_Identifier
(Parent
(P
));
18474 if Arg_Count
= 1 then
18475 Arg
:= Get_Pragma_Arg
(Arg1
);
18476 Val
:= Is_True
(Static_Boolean
(Arg
));
18478 -- No arguments (expression is considered to be True)
18484 -- Check duplicate pragma before we chain the pragma in the Rep
18485 -- Item chain of Ent.
18487 Check_Duplicate_Pragma
(Ent
);
18488 Record_Rep_Item
(Ent
, N
);
18489 Set_Uses_Lock_Free
(Ent
, Val
);
18491 -- Anything else is incorrect placement
18498 --------------------
18499 -- Locking_Policy --
18500 --------------------
18502 -- pragma Locking_Policy (policy_IDENTIFIER);
18504 when Pragma_Locking_Policy
=> declare
18505 subtype LP_Range
is Name_Id
18506 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
18511 Check_Ada_83_Warning
;
18512 Check_Arg_Count
(1);
18513 Check_No_Identifiers
;
18514 Check_Arg_Is_Locking_Policy
(Arg1
);
18515 Check_Valid_Configuration_Pragma
;
18516 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18519 when Name_Ceiling_Locking
=> LP
:= 'C';
18520 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
18521 when Name_Inheritance_Locking
=> LP
:= 'I';
18524 if Locking_Policy
/= ' '
18525 and then Locking_Policy
/= LP
18527 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18528 Error_Pragma
("locking policy incompatible with policy#");
18530 -- Set new policy, but always preserve System_Location since we
18531 -- like the error message with the run time name.
18534 Locking_Policy
:= LP
;
18536 if Locking_Policy_Sloc
/= System_Location
then
18537 Locking_Policy_Sloc
:= Loc
;
18542 -------------------
18543 -- Loop_Optimize --
18544 -------------------
18546 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18548 -- OPTIMIZATION_HINT ::=
18549 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18551 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
18556 Check_At_Least_N_Arguments
(1);
18557 Check_No_Identifiers
;
18559 Hint
:= First
(Pragma_Argument_Associations
(N
));
18560 while Present
(Hint
) loop
18561 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
18569 Check_Loop_Pragma_Placement
;
18576 -- pragma Loop_Variant
18577 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18579 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18581 -- CHANGE_DIRECTION ::= Increases | Decreases
18583 when Pragma_Loop_Variant
=> Loop_Variant
: declare
18588 Check_At_Least_N_Arguments
(1);
18589 Check_Loop_Pragma_Placement
;
18591 -- Process all increasing / decreasing expressions
18593 Variant
:= First
(Pragma_Argument_Associations
(N
));
18594 while Present
(Variant
) loop
18595 if Chars
(Variant
) = No_Name
then
18596 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
18598 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
18602 Name
: String := Get_Name_String
(Chars
(Variant
));
18605 -- It is a common mistake to write "Increasing" for
18606 -- "Increases" or "Decreasing" for "Decreases". Recognize
18607 -- specially names starting with "incr" or "decr" to
18608 -- suggest the corresponding name.
18610 System
.Case_Util
.To_Lower
(Name
);
18612 if Name
'Length >= 4
18613 and then Name
(1 .. 4) = "incr"
18615 Error_Pragma_Arg_Ident
18616 ("expect name `Increases`", Variant
);
18618 elsif Name
'Length >= 4
18619 and then Name
(1 .. 4) = "decr"
18621 Error_Pragma_Arg_Ident
18622 ("expect name `Decreases`", Variant
);
18625 Error_Pragma_Arg_Ident
18626 ("expect name `Increases` or `Decreases`", Variant
);
18631 Preanalyze_Assert_Expression
18632 (Expression
(Variant
), Any_Discrete
);
18638 -----------------------
18639 -- Machine_Attribute --
18640 -----------------------
18642 -- pragma Machine_Attribute (
18643 -- [Entity =>] LOCAL_NAME,
18644 -- [Attribute_Name =>] static_string_EXPRESSION
18645 -- [, [Info =>] static_EXPRESSION] );
18647 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
18648 Def_Id
: Entity_Id
;
18652 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
18654 if Arg_Count
= 3 then
18655 Check_Optional_Identifier
(Arg3
, Name_Info
);
18656 Check_Arg_Is_OK_Static_Expression
(Arg3
);
18658 Check_Arg_Count
(2);
18661 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18662 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
18663 Check_Arg_Is_Local_Name
(Arg1
);
18664 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18665 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18667 if Is_Access_Type
(Def_Id
) then
18668 Def_Id
:= Designated_Type
(Def_Id
);
18671 if Rep_Item_Too_Early
(Def_Id
, N
) then
18675 Def_Id
:= Underlying_Type
(Def_Id
);
18677 -- The only processing required is to link this item on to the
18678 -- list of rep items for the given entity. This is accomplished
18679 -- by the call to Rep_Item_Too_Late (when no error is detected
18680 -- and False is returned).
18682 if Rep_Item_Too_Late
(Def_Id
, N
) then
18685 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18687 end Machine_Attribute
;
18694 -- (MAIN_OPTION [, MAIN_OPTION]);
18697 -- [STACK_SIZE =>] static_integer_EXPRESSION
18698 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
18699 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
18701 when Pragma_Main
=> Main
: declare
18702 Args
: Args_List
(1 .. 3);
18703 Names
: constant Name_List
(1 .. 3) := (
18705 Name_Task_Stack_Size_Default
,
18706 Name_Time_Slicing_Enabled
);
18712 Gather_Associations
(Names
, Args
);
18714 for J
in 1 .. 2 loop
18715 if Present
(Args
(J
)) then
18716 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18720 if Present
(Args
(3)) then
18721 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
18725 while Present
(Nod
) loop
18726 if Nkind
(Nod
) = N_Pragma
18727 and then Pragma_Name
(Nod
) = Name_Main
18729 Error_Msg_Name_1
:= Pname
;
18730 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18741 -- pragma Main_Storage
18742 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
18744 -- MAIN_STORAGE_OPTION ::=
18745 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
18746 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
18748 when Pragma_Main_Storage
=> Main_Storage
: declare
18749 Args
: Args_List
(1 .. 2);
18750 Names
: constant Name_List
(1 .. 2) := (
18751 Name_Working_Storage
,
18758 Gather_Associations
(Names
, Args
);
18760 for J
in 1 .. 2 loop
18761 if Present
(Args
(J
)) then
18762 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18766 Check_In_Main_Program
;
18769 while Present
(Nod
) loop
18770 if Nkind
(Nod
) = N_Pragma
18771 and then Pragma_Name
(Nod
) = Name_Main_Storage
18773 Error_Msg_Name_1
:= Pname
;
18774 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18781 ----------------------
18782 -- Max_Queue_Length --
18783 ----------------------
18785 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
18787 -- This processing is shared by Pragma_Max_Entry_Queue_Depth
18789 when Pragma_Max_Queue_Length
18790 | Pragma_Max_Entry_Queue_Depth
18792 Max_Queue_Length
: declare
18794 Entry_Decl
: Node_Id
;
18795 Entry_Id
: Entity_Id
;
18799 if Prag_Id
= Pragma_Max_Queue_Length
then
18803 Check_Arg_Count
(1);
18806 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
18808 -- Entry declaration
18810 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
18812 -- Entry illegally within a task
18814 if Nkind
(Parent
(N
)) = N_Task_Definition
then
18815 Error_Pragma
("pragma % cannot apply to task entries");
18819 Entry_Id
:= Defining_Entity
(Entry_Decl
);
18821 -- Otherwise the pragma is associated with an illegal construct
18824 Error_Pragma
("pragma % must apply to a protected entry");
18828 -- Mark the pragma as Ghost if the related subprogram is also
18829 -- Ghost. This also ensures that any expansion performed further
18830 -- below will produce Ghost nodes.
18832 Mark_Ghost_Pragma
(N
, Entry_Id
);
18834 -- Analyze the Integer expression
18836 Arg
:= Get_Pragma_Arg
(Arg1
);
18837 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
18839 Val
:= Expr_Value
(Arg
);
18843 ("argument for pragma% must be positive", Arg1
);
18845 elsif not UI_Is_In_Int_Range
(Val
) then
18847 ("argument for pragma% out of range of Integer", Arg1
);
18851 -- Manually substitute the expression value of the pragma argument
18852 -- if it's not an integer literal because this is not taken care
18853 -- of automatically elsewhere.
18855 if Nkind
(Arg
) /= N_Integer_Literal
then
18856 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
18857 Set_Etype
(Arg
, Etype
(Original_Node
(Arg
)));
18860 Record_Rep_Item
(Entry_Id
, N
);
18861 end Max_Queue_Length
;
18867 -- pragma Memory_Size (NUMERIC_LITERAL)
18869 when Pragma_Memory_Size
=>
18872 -- Memory size is simply ignored
18874 Check_No_Identifiers
;
18875 Check_Arg_Count
(1);
18876 Check_Arg_Is_Integer_Literal
(Arg1
);
18884 -- The only correct use of this pragma is on its own in a file, in
18885 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18886 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18887 -- check for a file containing nothing but a No_Body pragma). If we
18888 -- attempt to process it during normal semantics processing, it means
18889 -- it was misplaced.
18891 when Pragma_No_Body
=>
18895 -----------------------------
18896 -- No_Elaboration_Code_All --
18897 -----------------------------
18899 -- pragma No_Elaboration_Code_All;
18901 when Pragma_No_Elaboration_Code_All
=>
18903 Check_Valid_Library_Unit_Pragma
;
18905 if Nkind
(N
) = N_Null_Statement
then
18909 -- Must appear for a spec or generic spec
18911 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18912 N_Generic_Package_Declaration
,
18913 N_Generic_Subprogram_Declaration
,
18914 N_Package_Declaration
,
18915 N_Subprogram_Declaration
)
18919 ("pragma% can only occur for package "
18920 & "or subprogram spec"));
18923 -- Set flag in unit table
18925 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18927 -- Set restriction No_Elaboration_Code if this is the main unit
18929 if Current_Sem_Unit
= Main_Unit
then
18930 Set_Restriction
(No_Elaboration_Code
, N
);
18933 -- If we are in the main unit or in an extended main source unit,
18934 -- then we also add it to the configuration restrictions so that
18935 -- it will apply to all units in the extended main source.
18937 if Current_Sem_Unit
= Main_Unit
18938 or else In_Extended_Main_Source_Unit
(N
)
18940 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18943 -- If in main extended unit, activate transitive with test
18945 if In_Extended_Main_Source_Unit
(N
) then
18946 Opt
.No_Elab_Code_All_Pragma
:= N
;
18949 -----------------------------
18950 -- No_Component_Reordering --
18951 -----------------------------
18953 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18955 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
18961 Check_At_Most_N_Arguments
(1);
18963 if Arg_Count
= 0 then
18964 Check_Valid_Configuration_Pragma
;
18965 Opt
.No_Component_Reordering
:= True;
18968 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18969 Check_Arg_Is_Local_Name
(Arg1
);
18970 E_Id
:= Get_Pragma_Arg
(Arg1
);
18972 if Etype
(E_Id
) = Any_Type
then
18976 E
:= Entity
(E_Id
);
18978 if not Is_Record_Type
(E
) then
18979 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
18982 Set_No_Reordering
(Base_Type
(E
));
18984 end No_Comp_Reordering
;
18986 --------------------------
18987 -- No_Heap_Finalization --
18988 --------------------------
18990 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18992 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18993 Context
: constant Node_Id
:= Parent
(N
);
18994 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19000 Check_No_Identifiers
;
19002 -- The pragma appears in a configuration file
19004 if No
(Context
) then
19005 Check_Arg_Count
(0);
19006 Check_Valid_Configuration_Pragma
;
19008 -- Detect a duplicate pragma
19010 if Present
(No_Heap_Finalization_Pragma
) then
19013 Prev
=> No_Heap_Finalization_Pragma
);
19017 No_Heap_Finalization_Pragma
:= N
;
19019 -- Otherwise the pragma should be associated with a library-level
19020 -- named access-to-object type.
19023 Check_Arg_Count
(1);
19024 Check_Arg_Is_Local_Name
(Arg1
);
19026 Find_Type
(Typ_Arg
);
19027 Typ
:= Entity
(Typ_Arg
);
19029 -- The type being subjected to the pragma is erroneous
19031 if Typ
= Any_Type
then
19032 Error_Pragma
("cannot find type referenced by pragma %");
19034 -- The pragma is applied to an incomplete or generic formal
19035 -- type way too early.
19037 elsif Rep_Item_Too_Early
(Typ
, N
) then
19041 Typ
:= Underlying_Type
(Typ
);
19044 -- The pragma must apply to an access-to-object type
19046 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
19049 -- Give a detailed error message on all other access type kinds
19051 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19053 ("pragma % cannot apply to access protected subprogram "
19056 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19058 ("pragma % cannot apply to access subprogram type");
19060 elsif Is_Anonymous_Access_Type
(Typ
) then
19062 ("pragma % cannot apply to anonymous access type");
19064 -- Give a general error message in case the pragma applies to a
19065 -- non-access type.
19069 ("pragma % must apply to library level access type");
19072 -- At this point the argument denotes an access-to-object type.
19073 -- Ensure that the type is declared at the library level.
19075 if Is_Library_Level_Entity
(Typ
) then
19078 -- Quietly ignore an access-to-object type originally declared
19079 -- at the library level within a generic, but instantiated at
19080 -- a non-library level. As a result the access-to-object type
19081 -- "loses" its No_Heap_Finalization property.
19083 elsif In_Instance
then
19088 ("pragma % must apply to library level access type");
19091 -- Detect a duplicate pragma
19093 if Present
(No_Heap_Finalization_Pragma
) then
19096 Prev
=> No_Heap_Finalization_Pragma
);
19100 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19102 if Present
(Prev
) then
19110 Record_Rep_Item
(Typ
, N
);
19112 end No_Heap_Finalization
;
19118 -- pragma No_Inline ( NAME {, NAME} );
19120 when Pragma_No_Inline
=>
19122 Process_Inline
(Suppressed
);
19128 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19130 when Pragma_No_Return
=> No_Return
: declare
19136 Ghost_Error_Posted
: Boolean := False;
19137 -- Flag set when an error concerning the illegal mix of Ghost and
19138 -- non-Ghost subprograms is emitted.
19140 Ghost_Id
: Entity_Id
:= Empty
;
19141 -- The entity of the first Ghost procedure encountered while
19142 -- processing the arguments of the pragma.
19146 Check_At_Least_N_Arguments
(1);
19148 -- Loop through arguments of pragma
19151 while Present
(Arg
) loop
19152 Check_Arg_Is_Local_Name
(Arg
);
19153 Id
:= Get_Pragma_Arg
(Arg
);
19156 if not Is_Entity_Name
(Id
) then
19157 Error_Pragma_Arg
("entity name required", Arg
);
19160 if Etype
(Id
) = Any_Type
then
19164 -- Loop to find matching procedures
19170 and then Scope
(E
) = Current_Scope
19172 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
19174 -- Check that the pragma is not applied to a body.
19175 -- First check the specless body case, to give a
19176 -- different error message. These checks do not apply
19177 -- if Relaxed_RM_Semantics, to accommodate other Ada
19178 -- compilers. Disable these checks under -gnatd.J.
19180 if not Debug_Flag_Dot_JJ
then
19181 if Nkind
(Parent
(Declaration_Node
(E
))) =
19183 and then not Relaxed_RM_Semantics
19186 ("pragma% requires separate spec and must come "
19190 -- Now the "specful" body case
19192 if Rep_Item_Too_Late
(E
, N
) then
19199 -- A pragma that applies to a Ghost entity becomes Ghost
19200 -- for the purposes of legality checks and removal of
19201 -- ignored Ghost code.
19203 Mark_Ghost_Pragma
(N
, E
);
19205 -- Capture the entity of the first Ghost procedure being
19206 -- processed for error detection purposes.
19208 if Is_Ghost_Entity
(E
) then
19209 if No
(Ghost_Id
) then
19213 -- Otherwise the subprogram is non-Ghost. It is illegal
19214 -- to mix references to Ghost and non-Ghost entities
19217 elsif Present
(Ghost_Id
)
19218 and then not Ghost_Error_Posted
19220 Ghost_Error_Posted
:= True;
19222 Error_Msg_Name_1
:= Pname
;
19224 ("pragma % cannot mention ghost and non-ghost "
19225 & "procedures", N
);
19227 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19228 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
19230 Error_Msg_Sloc
:= Sloc
(E
);
19231 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
19234 -- Set flag on any alias as well
19236 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
19237 Set_No_Return
(Alias
(E
));
19243 exit when From_Aspect_Specification
(N
);
19247 -- If entity in not in current scope it may be the enclosing
19248 -- suprogram body to which the aspect applies.
19251 if Entity
(Id
) = Current_Scope
19252 and then From_Aspect_Specification
(N
)
19254 Set_No_Return
(Entity
(Id
));
19256 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
19268 -- pragma No_Run_Time;
19270 -- Note: this pragma is retained for backwards compatibility. See
19271 -- body of Rtsfind for full details on its handling.
19273 when Pragma_No_Run_Time
=>
19275 Check_Valid_Configuration_Pragma
;
19276 Check_Arg_Count
(0);
19278 -- Remove backward compatibility if Build_Type is FSF or GPL and
19279 -- generate a warning.
19282 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
19285 Error_Pragma
("pragma% is ignored, has no effect??");
19287 No_Run_Time_Mode
:= True;
19288 Configurable_Run_Time_Mode
:= True;
19290 -- Set Duration to 32 bits if word size is 32
19292 if Ttypes
.System_Word_Size
= 32 then
19293 Duration_32_Bits_On_Target
:= True;
19296 -- Set appropriate restrictions
19298 Set_Restriction
(No_Finalization
, N
);
19299 Set_Restriction
(No_Exception_Handlers
, N
);
19300 Set_Restriction
(Max_Tasks
, N
, 0);
19301 Set_Restriction
(No_Tasking
, N
);
19305 -----------------------
19306 -- No_Tagged_Streams --
19307 -----------------------
19309 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19311 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
19317 Check_At_Most_N_Arguments
(1);
19319 -- One argument case
19321 if Arg_Count
= 1 then
19322 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19323 Check_Arg_Is_Local_Name
(Arg1
);
19324 E_Id
:= Get_Pragma_Arg
(Arg1
);
19326 if Etype
(E_Id
) = Any_Type
then
19330 E
:= Entity
(E_Id
);
19332 Check_Duplicate_Pragma
(E
);
19334 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
19336 ("argument for pragma% must be root tagged type", Arg1
);
19339 if Rep_Item_Too_Early
(E
, N
)
19341 Rep_Item_Too_Late
(E
, N
)
19345 Set_No_Tagged_Streams_Pragma
(E
, N
);
19348 -- Zero argument case
19351 Check_Is_In_Decl_Part_Or_Package_Spec
;
19352 No_Tagged_Streams
:= N
;
19354 end No_Tagged_Strms
;
19356 ------------------------
19357 -- No_Strict_Aliasing --
19358 ------------------------
19360 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19362 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
19368 Check_At_Most_N_Arguments
(1);
19370 if Arg_Count
= 0 then
19371 Check_Valid_Configuration_Pragma
;
19372 Opt
.No_Strict_Aliasing
:= True;
19375 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19376 Check_Arg_Is_Local_Name
(Arg1
);
19377 E_Id
:= Get_Pragma_Arg
(Arg1
);
19379 if Etype
(E_Id
) = Any_Type
then
19383 E
:= Entity
(E_Id
);
19385 if not Is_Access_Type
(E
) then
19386 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
19389 Set_No_Strict_Aliasing
(Base_Type
(E
));
19391 end No_Strict_Aliasing
;
19393 -----------------------
19394 -- Normalize_Scalars --
19395 -----------------------
19397 -- pragma Normalize_Scalars;
19399 when Pragma_Normalize_Scalars
=>
19400 Check_Ada_83_Warning
;
19401 Check_Arg_Count
(0);
19402 Check_Valid_Configuration_Pragma
;
19404 -- Normalize_Scalars creates false positives in CodePeer, and
19405 -- incorrect negative results in GNATprove mode, so ignore this
19406 -- pragma in these modes.
19408 if not (CodePeer_Mode
or GNATprove_Mode
) then
19409 Normalize_Scalars
:= True;
19410 Init_Or_Norm_Scalars
:= True;
19417 -- pragma Obsolescent;
19419 -- pragma Obsolescent (
19420 -- [Message =>] static_string_EXPRESSION
19421 -- [,[Version =>] Ada_05]]);
19423 -- pragma Obsolescent (
19424 -- [Entity =>] NAME
19425 -- [,[Message =>] static_string_EXPRESSION
19426 -- [,[Version =>] Ada_05]] );
19428 when Pragma_Obsolescent
=> Obsolescent
: declare
19432 procedure Set_Obsolescent
(E
: Entity_Id
);
19433 -- Given an entity Ent, mark it as obsolescent if appropriate
19435 ---------------------
19436 -- Set_Obsolescent --
19437 ---------------------
19439 procedure Set_Obsolescent
(E
: Entity_Id
) is
19448 -- A pragma that applies to a Ghost entity becomes Ghost for
19449 -- the purposes of legality checks and removal of ignored Ghost
19452 Mark_Ghost_Pragma
(N
, E
);
19454 -- Entity name was given
19456 if Present
(Ename
) then
19458 -- If entity name matches, we are fine. Save entity in
19459 -- pragma argument, for ASIS use.
19461 if Chars
(Ename
) = Chars
(Ent
) then
19462 Set_Entity
(Ename
, Ent
);
19463 Generate_Reference
(Ent
, Ename
);
19465 -- If entity name does not match, only possibility is an
19466 -- enumeration literal from an enumeration type declaration.
19468 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
19470 ("pragma % entity name does not match declaration");
19473 Ent
:= First_Literal
(E
);
19477 ("pragma % entity name does not match any "
19478 & "enumeration literal");
19480 elsif Chars
(Ent
) = Chars
(Ename
) then
19481 Set_Entity
(Ename
, Ent
);
19482 Generate_Reference
(Ent
, Ename
);
19486 Ent
:= Next_Literal
(Ent
);
19492 -- Ent points to entity to be marked
19494 if Arg_Count
>= 1 then
19496 -- Deal with static string argument
19498 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19499 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
19501 for J
in 1 .. String_Length
(S
) loop
19502 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
19504 ("pragma% argument does not allow wide characters",
19509 Obsolescent_Warnings
.Append
19510 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
19512 -- Check for Ada_05 parameter
19514 if Arg_Count
/= 1 then
19515 Check_Arg_Count
(2);
19518 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19521 Check_Arg_Is_Identifier
(Argx
);
19523 if Chars
(Argx
) /= Name_Ada_05
then
19524 Error_Msg_Name_2
:= Name_Ada_05
;
19526 ("only allowed argument for pragma% is %", Argx
);
19529 if Ada_Version_Explicit
< Ada_2005
19530 or else not Warn_On_Ada_2005_Compatibility
19538 -- Set flag if pragma active
19541 Set_Is_Obsolescent
(Ent
);
19545 end Set_Obsolescent
;
19547 -- Start of processing for pragma Obsolescent
19552 Check_At_Most_N_Arguments
(3);
19554 -- See if first argument specifies an entity name
19558 (Chars
(Arg1
) = Name_Entity
19560 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
19562 N_Operator_Symbol
))
19564 Ename
:= Get_Pragma_Arg
(Arg1
);
19566 -- Eliminate first argument, so we can share processing
19570 Arg_Count
:= Arg_Count
- 1;
19572 -- No Entity name argument given
19578 if Arg_Count
>= 1 then
19579 Check_Optional_Identifier
(Arg1
, Name_Message
);
19581 if Arg_Count
= 2 then
19582 Check_Optional_Identifier
(Arg2
, Name_Version
);
19586 -- Get immediately preceding declaration
19589 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
19593 -- Cases where we do not follow anything other than another pragma
19597 -- First case: library level compilation unit declaration with
19598 -- the pragma immediately following the declaration.
19600 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
19602 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
19605 -- Case 2: library unit placement for package
19609 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
19611 if Is_Package_Or_Generic_Package
(Ent
) then
19612 Set_Obsolescent
(Ent
);
19618 -- Cases where we must follow a declaration, including an
19619 -- abstract subprogram declaration, which is not in the
19620 -- other node subtypes.
19623 if Nkind
(Decl
) not in N_Declaration
19624 and then Nkind
(Decl
) not in N_Later_Decl_Item
19625 and then Nkind
(Decl
) not in N_Generic_Declaration
19626 and then Nkind
(Decl
) not in N_Renaming_Declaration
19627 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
19630 ("pragma% misplaced, "
19631 & "must immediately follow a declaration");
19634 Set_Obsolescent
(Defining_Entity
(Decl
));
19644 -- pragma Optimize (Time | Space | Off);
19646 -- The actual check for optimize is done in Gigi. Note that this
19647 -- pragma does not actually change the optimization setting, it
19648 -- simply checks that it is consistent with the pragma.
19650 when Pragma_Optimize
=>
19651 Check_No_Identifiers
;
19652 Check_Arg_Count
(1);
19653 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
19655 ------------------------
19656 -- Optimize_Alignment --
19657 ------------------------
19659 -- pragma Optimize_Alignment (Time | Space | Off);
19661 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
19663 Check_No_Identifiers
;
19664 Check_Arg_Count
(1);
19665 Check_Valid_Configuration_Pragma
;
19668 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
19671 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
19672 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
19673 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
19676 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
19680 -- Set indication that mode is set locally. If we are in fact in a
19681 -- configuration pragma file, this setting is harmless since the
19682 -- switch will get reset anyway at the start of each unit.
19684 Optimize_Alignment_Local
:= True;
19685 end Optimize_Alignment
;
19691 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
19693 when Pragma_Ordered
=> Ordered
: declare
19694 Assoc
: constant Node_Id
:= Arg1
;
19700 Check_No_Identifiers
;
19701 Check_Arg_Count
(1);
19702 Check_Arg_Is_Local_Name
(Arg1
);
19704 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19705 Find_Type
(Type_Id
);
19706 Typ
:= Entity
(Type_Id
);
19708 if Typ
= Any_Type
then
19711 Typ
:= Underlying_Type
(Typ
);
19714 if not Is_Enumeration_Type
(Typ
) then
19715 Error_Pragma
("pragma% must specify enumeration type");
19718 Check_First_Subtype
(Arg1
);
19719 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
19722 -------------------
19723 -- Overflow_Mode --
19724 -------------------
19726 -- pragma Overflow_Mode
19727 -- ([General => ] MODE [, [Assertions => ] MODE]);
19729 -- MODE := STRICT | MINIMIZED | ELIMINATED
19731 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
19732 -- since System.Bignums makes this assumption. This is true of nearly
19733 -- all (all?) targets.
19735 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
19736 function Get_Overflow_Mode
19738 Arg
: Node_Id
) return Overflow_Mode_Type
;
19739 -- Function to process one pragma argument, Arg. If an identifier
19740 -- is present, it must be Name. Mode type is returned if a valid
19741 -- argument exists, otherwise an error is signalled.
19743 -----------------------
19744 -- Get_Overflow_Mode --
19745 -----------------------
19747 function Get_Overflow_Mode
19749 Arg
: Node_Id
) return Overflow_Mode_Type
19751 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
19754 Check_Optional_Identifier
(Arg
, Name
);
19755 Check_Arg_Is_Identifier
(Argx
);
19757 if Chars
(Argx
) = Name_Strict
then
19760 elsif Chars
(Argx
) = Name_Minimized
then
19763 elsif Chars
(Argx
) = Name_Eliminated
then
19764 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
19766 ("Eliminated not implemented on this target", Argx
);
19772 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
19774 end Get_Overflow_Mode
;
19776 -- Start of processing for Overflow_Mode
19780 Check_At_Least_N_Arguments
(1);
19781 Check_At_Most_N_Arguments
(2);
19783 -- Process first argument
19785 Scope_Suppress
.Overflow_Mode_General
:=
19786 Get_Overflow_Mode
(Name_General
, Arg1
);
19788 -- Case of only one argument
19790 if Arg_Count
= 1 then
19791 Scope_Suppress
.Overflow_Mode_Assertions
:=
19792 Scope_Suppress
.Overflow_Mode_General
;
19794 -- Case of two arguments present
19797 Scope_Suppress
.Overflow_Mode_Assertions
:=
19798 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
19802 --------------------------
19803 -- Overriding Renamings --
19804 --------------------------
19806 -- pragma Overriding_Renamings;
19808 when Pragma_Overriding_Renamings
=>
19810 Check_Arg_Count
(0);
19811 Check_Valid_Configuration_Pragma
;
19812 Overriding_Renamings
:= True;
19818 -- pragma Pack (first_subtype_LOCAL_NAME);
19820 when Pragma_Pack
=> Pack
: declare
19821 Assoc
: constant Node_Id
:= Arg1
;
19823 Ignore
: Boolean := False;
19828 Check_No_Identifiers
;
19829 Check_Arg_Count
(1);
19830 Check_Arg_Is_Local_Name
(Arg1
);
19831 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19833 if not Is_Entity_Name
(Type_Id
)
19834 or else not Is_Type
(Entity
(Type_Id
))
19837 ("argument for pragma% must be type or subtype", Arg1
);
19840 Find_Type
(Type_Id
);
19841 Typ
:= Entity
(Type_Id
);
19844 or else Rep_Item_Too_Early
(Typ
, N
)
19848 Typ
:= Underlying_Type
(Typ
);
19851 -- A pragma that applies to a Ghost entity becomes Ghost for the
19852 -- purposes of legality checks and removal of ignored Ghost code.
19854 Mark_Ghost_Pragma
(N
, Typ
);
19856 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
19857 Error_Pragma
("pragma% must specify array or record type");
19860 Check_First_Subtype
(Arg1
);
19861 Check_Duplicate_Pragma
(Typ
);
19865 if Is_Array_Type
(Typ
) then
19866 Ctyp
:= Component_Type
(Typ
);
19868 -- Ignore pack that does nothing
19870 if Known_Static_Esize
(Ctyp
)
19871 and then Known_Static_RM_Size
(Ctyp
)
19872 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
19873 and then Addressable
(Esize
(Ctyp
))
19878 -- Process OK pragma Pack. Note that if there is a separate
19879 -- component clause present, the Pack will be cancelled. This
19880 -- processing is in Freeze.
19882 if not Rep_Item_Too_Late
(Typ
, N
) then
19884 -- In CodePeer mode, we do not need complex front-end
19885 -- expansions related to pragma Pack, so disable handling
19888 if CodePeer_Mode
then
19891 -- Normal case where we do the pack action
19895 Set_Is_Packed
(Base_Type
(Typ
));
19896 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19899 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19903 -- For record types, the pack is always effective
19905 else pragma Assert
(Is_Record_Type
(Typ
));
19906 if not Rep_Item_Too_Late
(Typ
, N
) then
19907 Set_Is_Packed
(Base_Type
(Typ
));
19908 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19909 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19920 -- There is nothing to do here, since we did all the processing for
19921 -- this pragma in Par.Prag (so that it works properly even in syntax
19924 when Pragma_Page
=>
19931 -- pragma Part_Of (ABSTRACT_STATE);
19933 -- ABSTRACT_STATE ::= NAME
19935 when Pragma_Part_Of
=> Part_Of
: declare
19936 procedure Propagate_Part_Of
19937 (Pack_Id
: Entity_Id
;
19938 State_Id
: Entity_Id
;
19939 Instance
: Node_Id
);
19940 -- Propagate the Part_Of indicator to all abstract states and
19941 -- objects declared in the visible state space of a package
19942 -- denoted by Pack_Id. State_Id is the encapsulating state.
19943 -- Instance is the package instantiation node.
19945 -----------------------
19946 -- Propagate_Part_Of --
19947 -----------------------
19949 procedure Propagate_Part_Of
19950 (Pack_Id
: Entity_Id
;
19951 State_Id
: Entity_Id
;
19952 Instance
: Node_Id
)
19954 Has_Item
: Boolean := False;
19955 -- Flag set when the visible state space contains at least one
19956 -- abstract state or variable.
19958 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19959 -- Propagate the Part_Of indicator to all abstract states and
19960 -- objects declared in the visible state space of a package
19961 -- denoted by Pack_Id.
19963 -----------------------
19964 -- Propagate_Part_Of --
19965 -----------------------
19967 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19968 Constits
: Elist_Id
;
19969 Item_Id
: Entity_Id
;
19972 -- Traverse the entity chain of the package and set relevant
19973 -- attributes of abstract states and objects declared in the
19974 -- visible state space of the package.
19976 Item_Id
:= First_Entity
(Pack_Id
);
19977 while Present
(Item_Id
)
19978 and then not In_Private_Part
(Item_Id
)
19980 -- Do not consider internally generated items
19982 if not Comes_From_Source
(Item_Id
) then
19985 -- The Part_Of indicator turns an abstract state or an
19986 -- object into a constituent of the encapsulating state.
19988 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19993 Constits
:= Part_Of_Constituents
(State_Id
);
19995 if No
(Constits
) then
19996 Constits
:= New_Elmt_List
;
19997 Set_Part_Of_Constituents
(State_Id
, Constits
);
20000 Append_Elmt
(Item_Id
, Constits
);
20001 Set_Encapsulating_State
(Item_Id
, State_Id
);
20003 -- Recursively handle nested packages and instantiations
20005 elsif Ekind
(Item_Id
) = E_Package
then
20006 Propagate_Part_Of
(Item_Id
);
20009 Next_Entity
(Item_Id
);
20011 end Propagate_Part_Of
;
20013 -- Start of processing for Propagate_Part_Of
20016 Propagate_Part_Of
(Pack_Id
);
20018 -- Detect a package instantiation that is subject to a Part_Of
20019 -- indicator, but has no visible state.
20021 if not Has_Item
then
20023 ("package instantiation & has Part_Of indicator but "
20024 & "lacks visible state", Instance
, Pack_Id
);
20026 end Propagate_Part_Of
;
20030 Constits
: Elist_Id
;
20032 Encap_Id
: Entity_Id
;
20033 Item_Id
: Entity_Id
;
20037 -- Start of processing for Part_Of
20041 Check_No_Identifiers
;
20042 Check_Arg_Count
(1);
20044 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
20046 -- Object declaration
20048 if Nkind
(Stmt
) = N_Object_Declaration
then
20051 -- Package instantiation
20053 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
20056 -- Single concurrent type declaration
20058 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
20061 -- Otherwise the pragma is associated with an illegal construct
20068 -- Extract the entity of the related object declaration or package
20069 -- instantiation. In the case of the instantiation, use the entity
20070 -- of the instance spec.
20072 if Nkind
(Stmt
) = N_Package_Instantiation
then
20073 Stmt
:= Instance_Spec
(Stmt
);
20076 Item_Id
:= Defining_Entity
(Stmt
);
20078 -- A pragma that applies to a Ghost entity becomes Ghost for the
20079 -- purposes of legality checks and removal of ignored Ghost code.
20081 Mark_Ghost_Pragma
(N
, Item_Id
);
20083 -- Chain the pragma on the contract for further processing by
20084 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20086 Add_Contract_Item
(N
, Item_Id
);
20088 -- A variable may act as constituent of a single concurrent type
20089 -- which in turn could be declared after the variable. Due to this
20090 -- discrepancy, the full analysis of indicator Part_Of is delayed
20091 -- until the end of the enclosing declarative region (see routine
20092 -- Analyze_Part_Of_In_Decl_Part).
20094 if Ekind
(Item_Id
) = E_Variable
then
20097 -- Otherwise indicator Part_Of applies to a constant or a package
20101 Encap
:= Get_Pragma_Arg
(Arg1
);
20103 -- Detect any discrepancies between the placement of the
20104 -- constant or package instantiation with respect to state
20105 -- space and the encapsulating state.
20109 Item_Id
=> Item_Id
,
20111 Encap_Id
=> Encap_Id
,
20115 pragma Assert
(Present
(Encap_Id
));
20117 if Ekind
(Item_Id
) = E_Constant
then
20118 Constits
:= Part_Of_Constituents
(Encap_Id
);
20120 if No
(Constits
) then
20121 Constits
:= New_Elmt_List
;
20122 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
20125 Append_Elmt
(Item_Id
, Constits
);
20126 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
20128 -- Propagate the Part_Of indicator to the visible state
20129 -- space of the package instantiation.
20133 (Pack_Id
=> Item_Id
,
20134 State_Id
=> Encap_Id
,
20141 ----------------------------------
20142 -- Partition_Elaboration_Policy --
20143 ----------------------------------
20145 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20147 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
20148 subtype PEP_Range
is Name_Id
20149 range First_Partition_Elaboration_Policy_Name
20150 .. Last_Partition_Elaboration_Policy_Name
;
20151 PEP_Val
: PEP_Range
;
20156 Check_Arg_Count
(1);
20157 Check_No_Identifiers
;
20158 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
20159 Check_Valid_Configuration_Pragma
;
20160 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20163 when Name_Concurrent
=> PEP
:= 'C';
20164 when Name_Sequential
=> PEP
:= 'S';
20167 if Partition_Elaboration_Policy
/= ' '
20168 and then Partition_Elaboration_Policy
/= PEP
20170 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
20172 ("partition elaboration policy incompatible with policy#");
20174 -- Set new policy, but always preserve System_Location since we
20175 -- like the error message with the run time name.
20178 Partition_Elaboration_Policy
:= PEP
;
20180 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
20181 Partition_Elaboration_Policy_Sloc
:= Loc
;
20190 -- pragma Passive [(PASSIVE_FORM)];
20192 -- PASSIVE_FORM ::= Semaphore | No
20194 when Pragma_Passive
=>
20197 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
20198 Error_Pragma
("pragma% must be within task definition");
20201 if Arg_Count
/= 0 then
20202 Check_Arg_Count
(1);
20203 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
20206 ----------------------------------
20207 -- Preelaborable_Initialization --
20208 ----------------------------------
20210 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20212 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
20217 Check_Arg_Count
(1);
20218 Check_No_Identifiers
;
20219 Check_Arg_Is_Identifier
(Arg1
);
20220 Check_Arg_Is_Local_Name
(Arg1
);
20221 Check_First_Subtype
(Arg1
);
20222 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20224 -- A pragma that applies to a Ghost entity becomes Ghost for the
20225 -- purposes of legality checks and removal of ignored Ghost code.
20227 Mark_Ghost_Pragma
(N
, Ent
);
20229 -- The pragma may come from an aspect on a private declaration,
20230 -- even if the freeze point at which this is analyzed in the
20231 -- private part after the full view.
20233 if Has_Private_Declaration
(Ent
)
20234 and then From_Aspect_Specification
(N
)
20238 -- Check appropriate type argument
20240 elsif Is_Private_Type
(Ent
)
20241 or else Is_Protected_Type
(Ent
)
20242 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
20244 -- AI05-0028: The pragma applies to all composite types. Note
20245 -- that we apply this binding interpretation to earlier versions
20246 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20247 -- choice since there are other compilers that do the same.
20249 or else Is_Composite_Type
(Ent
)
20255 ("pragma % can only be applied to private, formal derived, "
20256 & "protected, or composite type", Arg1
);
20259 -- Give an error if the pragma is applied to a protected type that
20260 -- does not qualify (due to having entries, or due to components
20261 -- that do not qualify).
20263 if Is_Protected_Type
(Ent
)
20264 and then not Has_Preelaborable_Initialization
(Ent
)
20267 ("protected type & does not have preelaborable "
20268 & "initialization", Ent
);
20270 -- Otherwise mark the type as definitely having preelaborable
20274 Set_Known_To_Have_Preelab_Init
(Ent
);
20277 if Has_Pragma_Preelab_Init
(Ent
)
20278 and then Warn_On_Redundant_Constructs
20280 Error_Pragma
("?r?duplicate pragma%!");
20282 Set_Has_Pragma_Preelab_Init
(Ent
);
20286 --------------------
20287 -- Persistent_BSS --
20288 --------------------
20290 -- pragma Persistent_BSS [(object_NAME)];
20292 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
20299 Check_At_Most_N_Arguments
(1);
20301 -- Case of application to specific object (one argument)
20303 if Arg_Count
= 1 then
20304 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20306 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
20308 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
20311 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
20314 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20316 -- A pragma that applies to a Ghost entity becomes Ghost for
20317 -- the purposes of legality checks and removal of ignored Ghost
20320 Mark_Ghost_Pragma
(N
, Ent
);
20322 -- Check for duplication before inserting in list of
20323 -- representation items.
20325 Check_Duplicate_Pragma
(Ent
);
20327 if Rep_Item_Too_Late
(Ent
, N
) then
20331 Decl
:= Parent
(Ent
);
20333 if Present
(Expression
(Decl
)) then
20335 ("object for pragma% cannot have initialization", Arg1
);
20338 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
20340 ("object type for pragma% is not potentially persistent",
20345 Make_Linker_Section_Pragma
20346 (Ent
, Sloc
(N
), ".persistent.bss");
20347 Insert_After
(N
, Prag
);
20350 -- Case of use as configuration pragma with no arguments
20353 Check_Valid_Configuration_Pragma
;
20354 Persistent_BSS_Mode
:= True;
20356 end Persistent_BSS
;
20358 --------------------
20359 -- Rename_Pragma --
20360 --------------------
20362 -- pragma Rename_Pragma (
20363 -- [New_Name =>] IDENTIFIER,
20364 -- [Renamed =>] pragma_IDENTIFIER);
20366 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
20367 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20368 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20372 Check_Valid_Configuration_Pragma
;
20373 Check_Arg_Count
(2);
20374 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
20375 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
20377 if Nkind
(New_Name
) /= N_Identifier
then
20378 Error_Pragma_Arg
("identifier expected", Arg1
);
20381 if Nkind
(Old_Name
) /= N_Identifier
then
20382 Error_Pragma_Arg
("identifier expected", Arg2
);
20385 -- The New_Name arg should not be an existing pragma (but we allow
20386 -- it; it's just a warning). The Old_Name arg must be an existing
20389 if Is_Pragma_Name
(Chars
(New_Name
)) then
20390 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
20393 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
20394 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
20397 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
20404 -- pragma Polling (ON | OFF);
20406 when Pragma_Polling
=>
20408 Check_Arg_Count
(1);
20409 Check_No_Identifiers
;
20410 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20411 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
20413 -----------------------------------
20414 -- Post/Post_Class/Postcondition --
20415 -----------------------------------
20417 -- pragma Post (Boolean_EXPRESSION);
20418 -- pragma Post_Class (Boolean_EXPRESSION);
20419 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20420 -- [,[Message =>] String_EXPRESSION]);
20422 -- Characteristics:
20424 -- * Analysis - The annotation undergoes initial checks to verify
20425 -- the legal placement and context. Secondary checks preanalyze the
20428 -- Analyze_Pre_Post_Condition_In_Decl_Part
20430 -- * Expansion - The annotation is expanded during the expansion of
20431 -- the related subprogram [body] contract as performed in:
20433 -- Expand_Subprogram_Contract
20435 -- * Template - The annotation utilizes the generic template of the
20436 -- related subprogram [body] when it is:
20438 -- aspect on subprogram declaration
20439 -- aspect on stand-alone subprogram body
20440 -- pragma on stand-alone subprogram body
20442 -- The annotation must prepare its own template when it is:
20444 -- pragma on subprogram declaration
20446 -- * Globals - Capture of global references must occur after full
20449 -- * Instance - The annotation is instantiated automatically when
20450 -- the related generic subprogram [body] is instantiated except for
20451 -- the "pragma on subprogram declaration" case. In that scenario
20452 -- the annotation must instantiate itself.
20455 | Pragma_Post_Class
20456 | Pragma_Postcondition
20458 Analyze_Pre_Post_Condition
;
20460 --------------------------------
20461 -- Pre/Pre_Class/Precondition --
20462 --------------------------------
20464 -- pragma Pre (Boolean_EXPRESSION);
20465 -- pragma Pre_Class (Boolean_EXPRESSION);
20466 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20467 -- [,[Message =>] String_EXPRESSION]);
20469 -- Characteristics:
20471 -- * Analysis - The annotation undergoes initial checks to verify
20472 -- the legal placement and context. Secondary checks preanalyze the
20475 -- Analyze_Pre_Post_Condition_In_Decl_Part
20477 -- * Expansion - The annotation is expanded during the expansion of
20478 -- the related subprogram [body] contract as performed in:
20480 -- Expand_Subprogram_Contract
20482 -- * Template - The annotation utilizes the generic template of the
20483 -- related subprogram [body] when it is:
20485 -- aspect on subprogram declaration
20486 -- aspect on stand-alone subprogram body
20487 -- pragma on stand-alone subprogram body
20489 -- The annotation must prepare its own template when it is:
20491 -- pragma on subprogram declaration
20493 -- * Globals - Capture of global references must occur after full
20496 -- * Instance - The annotation is instantiated automatically when
20497 -- the related generic subprogram [body] is instantiated except for
20498 -- the "pragma on subprogram declaration" case. In that scenario
20499 -- the annotation must instantiate itself.
20503 | Pragma_Precondition
20505 Analyze_Pre_Post_Condition
;
20511 -- pragma Predicate
20512 -- ([Entity =>] type_LOCAL_NAME,
20513 -- [Check =>] boolean_EXPRESSION);
20515 when Pragma_Predicate
=> Predicate
: declare
20522 Check_Arg_Count
(2);
20523 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20524 Check_Optional_Identifier
(Arg2
, Name_Check
);
20526 Check_Arg_Is_Local_Name
(Arg1
);
20528 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20529 Find_Type
(Type_Id
);
20530 Typ
:= Entity
(Type_Id
);
20532 if Typ
= Any_Type
then
20536 -- A pragma that applies to a Ghost entity becomes Ghost for the
20537 -- purposes of legality checks and removal of ignored Ghost code.
20539 Mark_Ghost_Pragma
(N
, Typ
);
20541 -- The remaining processing is simply to link the pragma on to
20542 -- the rep item chain, for processing when the type is frozen.
20543 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20544 -- mark the type as having predicates.
20546 -- If the current policy for predicate checking is Ignore mark the
20547 -- subtype accordingly. In the case of predicates we consider them
20548 -- enabled unless Ignore is specified (either directly or with a
20549 -- general Assertion_Policy pragma) to preserve existing warnings.
20551 Set_Has_Predicates
(Typ
);
20553 -- Indicate that the pragma must be processed at the point the
20554 -- type is frozen, as is done for the corresponding aspect.
20556 Set_Has_Delayed_Aspects
(Typ
);
20557 Set_Has_Delayed_Freeze
(Typ
);
20559 Set_Predicates_Ignored
(Typ
,
20560 Present
(Check_Policy_List
)
20562 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
20563 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20566 -----------------------
20567 -- Predicate_Failure --
20568 -----------------------
20570 -- pragma Predicate_Failure
20571 -- ([Entity =>] type_LOCAL_NAME,
20572 -- [Message =>] string_EXPRESSION);
20574 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
20581 Check_Arg_Count
(2);
20582 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20583 Check_Optional_Identifier
(Arg2
, Name_Message
);
20585 Check_Arg_Is_Local_Name
(Arg1
);
20587 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20588 Find_Type
(Type_Id
);
20589 Typ
:= Entity
(Type_Id
);
20591 if Typ
= Any_Type
then
20595 -- A pragma that applies to a Ghost entity becomes Ghost for the
20596 -- purposes of legality checks and removal of ignored Ghost code.
20598 Mark_Ghost_Pragma
(N
, Typ
);
20600 -- The remaining processing is simply to link the pragma on to
20601 -- the rep item chain, for processing when the type is frozen.
20602 -- This is accomplished by a call to Rep_Item_Too_Late.
20604 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20605 end Predicate_Failure
;
20611 -- pragma Preelaborate [(library_unit_NAME)];
20613 -- Set the flag Is_Preelaborated of program unit name entity
20615 when Pragma_Preelaborate
=> Preelaborate
: declare
20616 Pa
: constant Node_Id
:= Parent
(N
);
20617 Pk
: constant Node_Kind
:= Nkind
(Pa
);
20621 Check_Ada_83_Warning
;
20622 Check_Valid_Library_Unit_Pragma
;
20624 if Nkind
(N
) = N_Null_Statement
then
20628 Ent
:= Find_Lib_Unit_Name
;
20630 -- A pragma that applies to a Ghost entity becomes Ghost for the
20631 -- purposes of legality checks and removal of ignored Ghost code.
20633 Mark_Ghost_Pragma
(N
, Ent
);
20634 Check_Duplicate_Pragma
(Ent
);
20636 -- This filters out pragmas inside generic parents that show up
20637 -- inside instantiations. Pragmas that come from aspects in the
20638 -- unit are not ignored.
20640 if Present
(Ent
) then
20641 if Pk
= N_Package_Specification
20642 and then Present
(Generic_Parent
(Pa
))
20643 and then not From_Aspect_Specification
(N
)
20648 if not Debug_Flag_U
then
20649 Set_Is_Preelaborated
(Ent
);
20651 if Legacy_Elaboration_Checks
then
20652 Set_Suppress_Elaboration_Warnings
(Ent
);
20659 -------------------------------
20660 -- Prefix_Exception_Messages --
20661 -------------------------------
20663 -- pragma Prefix_Exception_Messages;
20665 when Pragma_Prefix_Exception_Messages
=>
20667 Check_Valid_Configuration_Pragma
;
20668 Check_Arg_Count
(0);
20669 Prefix_Exception_Messages
:= True;
20675 -- pragma Priority (EXPRESSION);
20677 when Pragma_Priority
=> Priority
: declare
20678 P
: constant Node_Id
:= Parent
(N
);
20683 Check_No_Identifiers
;
20684 Check_Arg_Count
(1);
20688 if Nkind
(P
) = N_Subprogram_Body
then
20689 Check_In_Main_Program
;
20691 Ent
:= Defining_Unit_Name
(Specification
(P
));
20693 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
20694 Ent
:= Defining_Identifier
(Ent
);
20697 Arg
:= Get_Pragma_Arg
(Arg1
);
20698 Analyze_And_Resolve
(Arg
, Standard_Integer
);
20702 if not Is_OK_Static_Expression
(Arg
) then
20703 Flag_Non_Static_Expr
20704 ("main subprogram priority is not static!", Arg
);
20707 -- If constraint error, then we already signalled an error
20709 elsif Raises_Constraint_Error
(Arg
) then
20712 -- Otherwise check in range except if Relaxed_RM_Semantics
20713 -- where we ignore the value if out of range.
20716 if not Relaxed_RM_Semantics
20717 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
20720 ("main subprogram priority is out of range", Arg1
);
20723 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
20727 -- Load an arbitrary entity from System.Tasking.Stages or
20728 -- System.Tasking.Restricted.Stages (depending on the
20729 -- supported profile) to make sure that one of these packages
20730 -- is implicitly with'ed, since we need to have the tasking
20731 -- run time active for the pragma Priority to have any effect.
20732 -- Previously we with'ed the package System.Tasking, but this
20733 -- package does not trigger the required initialization of the
20734 -- run-time library.
20737 Discard
: Entity_Id
;
20738 pragma Warnings
(Off
, Discard
);
20740 if Restricted_Profile
then
20741 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
20743 Discard
:= RTE
(RE_Activate_Tasks
);
20747 -- Task or Protected, must be of type Integer
20749 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
20750 Arg
:= Get_Pragma_Arg
(Arg1
);
20751 Ent
:= Defining_Identifier
(Parent
(P
));
20753 -- The expression must be analyzed in the special manner
20754 -- described in "Handling of Default and Per-Object
20755 -- Expressions" in sem.ads.
20757 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
20759 if not Is_OK_Static_Expression
(Arg
) then
20760 Check_Restriction
(Static_Priorities
, Arg
);
20763 -- Anything else is incorrect
20769 -- Check duplicate pragma before we chain the pragma in the Rep
20770 -- Item chain of Ent.
20772 Check_Duplicate_Pragma
(Ent
);
20773 Record_Rep_Item
(Ent
, N
);
20776 -----------------------------------
20777 -- Priority_Specific_Dispatching --
20778 -----------------------------------
20780 -- pragma Priority_Specific_Dispatching (
20781 -- policy_IDENTIFIER,
20782 -- first_priority_EXPRESSION,
20783 -- last_priority_EXPRESSION);
20785 when Pragma_Priority_Specific_Dispatching
=>
20786 Priority_Specific_Dispatching
: declare
20787 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
20788 -- This is the entity System.Any_Priority;
20791 Lower_Bound
: Node_Id
;
20792 Upper_Bound
: Node_Id
;
20798 Check_Arg_Count
(3);
20799 Check_No_Identifiers
;
20800 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20801 Check_Valid_Configuration_Pragma
;
20802 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20803 DP
:= Fold_Upper
(Name_Buffer
(1));
20805 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
20806 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
20807 Lower_Val
:= Expr_Value
(Lower_Bound
);
20809 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
20810 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
20811 Upper_Val
:= Expr_Value
(Upper_Bound
);
20813 -- It is not allowed to use Task_Dispatching_Policy and
20814 -- Priority_Specific_Dispatching in the same partition.
20816 if Task_Dispatching_Policy
/= ' ' then
20817 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20819 ("pragma% incompatible with Task_Dispatching_Policy#");
20821 -- Check lower bound in range
20823 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20825 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20828 ("first_priority is out of range", Arg2
);
20830 -- Check upper bound in range
20832 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20834 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20837 ("last_priority is out of range", Arg3
);
20839 -- Check that the priority range is valid
20841 elsif Lower_Val
> Upper_Val
then
20843 ("last_priority_expression must be greater than or equal to "
20844 & "first_priority_expression");
20846 -- Store the new policy, but always preserve System_Location since
20847 -- we like the error message with the run-time name.
20850 -- Check overlapping in the priority ranges specified in other
20851 -- Priority_Specific_Dispatching pragmas within the same
20852 -- partition. We can only check those we know about.
20855 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
20857 if Specific_Dispatching
.Table
(J
).First_Priority
in
20858 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20859 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
20860 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20863 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
20865 ("priority range overlaps with "
20866 & "Priority_Specific_Dispatching#");
20870 -- The use of Priority_Specific_Dispatching is incompatible
20871 -- with Task_Dispatching_Policy.
20873 if Task_Dispatching_Policy
/= ' ' then
20874 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20876 ("Priority_Specific_Dispatching incompatible "
20877 & "with Task_Dispatching_Policy#");
20880 -- The use of Priority_Specific_Dispatching forces ceiling
20883 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
20884 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20886 ("Priority_Specific_Dispatching incompatible "
20887 & "with Locking_Policy#");
20889 -- Set the Ceiling_Locking policy, but preserve System_Location
20890 -- since we like the error message with the run time name.
20893 Locking_Policy
:= 'C';
20895 if Locking_Policy_Sloc
/= System_Location
then
20896 Locking_Policy_Sloc
:= Loc
;
20900 -- Add entry in the table
20902 Specific_Dispatching
.Append
20903 ((Dispatching_Policy
=> DP
,
20904 First_Priority
=> UI_To_Int
(Lower_Val
),
20905 Last_Priority
=> UI_To_Int
(Upper_Val
),
20906 Pragma_Loc
=> Loc
));
20908 end Priority_Specific_Dispatching
;
20914 -- pragma Profile (profile_IDENTIFIER);
20916 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20918 when Pragma_Profile
=>
20920 Check_Arg_Count
(1);
20921 Check_Valid_Configuration_Pragma
;
20922 Check_No_Identifiers
;
20925 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20928 if Chars
(Argx
) = Name_Ravenscar
then
20929 Set_Ravenscar_Profile
(Ravenscar
, N
);
20931 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
20932 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
20934 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
20935 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
20937 elsif Chars
(Argx
) = Name_Restricted
then
20938 Set_Profile_Restrictions
20940 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20942 elsif Chars
(Argx
) = Name_Rational
then
20943 Set_Rational_Profile
;
20945 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20946 Set_Profile_Restrictions
20947 (No_Implementation_Extensions
,
20948 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20951 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20955 ----------------------
20956 -- Profile_Warnings --
20957 ----------------------
20959 -- pragma Profile_Warnings (profile_IDENTIFIER);
20961 -- profile_IDENTIFIER => Restricted | Ravenscar
20963 when Pragma_Profile_Warnings
=>
20965 Check_Arg_Count
(1);
20966 Check_Valid_Configuration_Pragma
;
20967 Check_No_Identifiers
;
20970 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20973 if Chars
(Argx
) = Name_Ravenscar
then
20974 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20976 elsif Chars
(Argx
) = Name_Restricted
then
20977 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20979 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20980 Set_Profile_Restrictions
20981 (No_Implementation_Extensions
, N
, Warn
=> True);
20984 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20988 --------------------------
20989 -- Propagate_Exceptions --
20990 --------------------------
20992 -- pragma Propagate_Exceptions;
20994 -- Note: this pragma is obsolete and has no effect
20996 when Pragma_Propagate_Exceptions
=>
20998 Check_Arg_Count
(0);
21000 if Warn_On_Obsolescent_Feature
then
21002 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21003 "and has no effect?j?", N
);
21006 -----------------------------
21007 -- Provide_Shift_Operators --
21008 -----------------------------
21010 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21012 when Pragma_Provide_Shift_Operators
=>
21013 Provide_Shift_Operators
: declare
21016 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21017 -- Insert declaration and pragma Instrinsic for named shift op
21019 ----------------------------
21020 -- Declare_Shift_Operator --
21021 ----------------------------
21023 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
21029 Make_Subprogram_Declaration
(Loc
,
21030 Make_Function_Specification
(Loc
,
21031 Defining_Unit_Name
=>
21032 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
21034 Result_Definition
=>
21035 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
21037 Parameter_Specifications
=> New_List
(
21038 Make_Parameter_Specification
(Loc
,
21039 Defining_Identifier
=>
21040 Make_Defining_Identifier
(Loc
, Name_Value
),
21042 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
21044 Make_Parameter_Specification
(Loc
,
21045 Defining_Identifier
=>
21046 Make_Defining_Identifier
(Loc
, Name_Amount
),
21048 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
21052 Chars
=> Name_Import
,
21053 Pragma_Argument_Associations
=> New_List
(
21054 Make_Pragma_Argument_Association
(Loc
,
21055 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
21056 Make_Pragma_Argument_Association
(Loc
,
21057 Expression
=> Make_Identifier
(Loc
, Nam
))));
21059 Insert_After
(N
, Import
);
21060 Insert_After
(N
, Func
);
21061 end Declare_Shift_Operator
;
21063 -- Start of processing for Provide_Shift_Operators
21067 Check_Arg_Count
(1);
21068 Check_Arg_Is_Local_Name
(Arg1
);
21070 Arg1
:= Get_Pragma_Arg
(Arg1
);
21072 -- We must have an entity name
21074 if not Is_Entity_Name
(Arg1
) then
21076 ("pragma % must apply to integer first subtype", Arg1
);
21079 -- If no Entity, means there was a prior error so ignore
21081 if Present
(Entity
(Arg1
)) then
21082 Ent
:= Entity
(Arg1
);
21084 -- Apply error checks
21086 if not Is_First_Subtype
(Ent
) then
21088 ("cannot apply pragma %",
21089 "\& is not a first subtype",
21092 elsif not Is_Integer_Type
(Ent
) then
21094 ("cannot apply pragma %",
21095 "\& is not an integer type",
21098 elsif Has_Shift_Operator
(Ent
) then
21100 ("cannot apply pragma %",
21101 "\& already has declared shift operators",
21104 elsif Is_Frozen
(Ent
) then
21106 ("pragma % appears too late",
21107 "\& is already frozen",
21111 -- Now declare the operators. We do this during analysis rather
21112 -- than expansion, since we want the operators available if we
21113 -- are operating in -gnatc or ASIS mode.
21115 Declare_Shift_Operator
(Name_Rotate_Left
);
21116 Declare_Shift_Operator
(Name_Rotate_Right
);
21117 Declare_Shift_Operator
(Name_Shift_Left
);
21118 Declare_Shift_Operator
(Name_Shift_Right
);
21119 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
21121 end Provide_Shift_Operators
;
21127 -- pragma Psect_Object (
21128 -- [Internal =>] LOCAL_NAME,
21129 -- [, [External =>] EXTERNAL_SYMBOL]
21130 -- [, [Size =>] EXTERNAL_SYMBOL]);
21132 when Pragma_Common_Object
21133 | Pragma_Psect_Object
21135 Psect_Object
: declare
21136 Args
: Args_List
(1 .. 3);
21137 Names
: constant Name_List
(1 .. 3) := (
21142 Internal
: Node_Id
renames Args
(1);
21143 External
: Node_Id
renames Args
(2);
21144 Size
: Node_Id
renames Args
(3);
21146 Def_Id
: Entity_Id
;
21148 procedure Check_Arg
(Arg
: Node_Id
);
21149 -- Checks that argument is either a string literal or an
21150 -- identifier, and posts error message if not.
21156 procedure Check_Arg
(Arg
: Node_Id
) is
21158 if not Nkind_In
(Original_Node
(Arg
),
21163 ("inappropriate argument for pragma %", Arg
);
21167 -- Start of processing for Common_Object/Psect_Object
21171 Gather_Associations
(Names
, Args
);
21172 Process_Extended_Import_Export_Internal_Arg
(Internal
);
21174 Def_Id
:= Entity
(Internal
);
21176 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
21178 ("pragma% must designate an object", Internal
);
21181 Check_Arg
(Internal
);
21183 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
21185 ("cannot use pragma% for imported/exported object",
21189 if Is_Concurrent_Type
(Etype
(Internal
)) then
21191 ("cannot specify pragma % for task/protected object",
21195 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
21197 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
21199 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
21202 if Ekind
(Def_Id
) = E_Constant
then
21204 ("cannot specify pragma % for a constant", Internal
);
21207 if Is_Record_Type
(Etype
(Internal
)) then
21213 Ent
:= First_Entity
(Etype
(Internal
));
21214 while Present
(Ent
) loop
21215 Decl
:= Declaration_Node
(Ent
);
21217 if Ekind
(Ent
) = E_Component
21218 and then Nkind
(Decl
) = N_Component_Declaration
21219 and then Present
(Expression
(Decl
))
21220 and then Warn_On_Export_Import
21223 ("?x?object for pragma % has defaults", Internal
);
21233 if Present
(Size
) then
21237 if Present
(External
) then
21238 Check_Arg_Is_External_Name
(External
);
21241 -- If all error tests pass, link pragma on to the rep item chain
21243 Record_Rep_Item
(Def_Id
, N
);
21250 -- pragma Pure [(library_unit_NAME)];
21252 when Pragma_Pure
=> Pure
: declare
21256 Check_Ada_83_Warning
;
21258 -- If the pragma comes from a subprogram instantiation, nothing to
21259 -- check, this can happen at any level of nesting.
21261 if Is_Wrapper_Package
(Current_Scope
) then
21264 Check_Valid_Library_Unit_Pragma
;
21267 if Nkind
(N
) = N_Null_Statement
then
21271 Ent
:= Find_Lib_Unit_Name
;
21273 -- A pragma that applies to a Ghost entity becomes Ghost for the
21274 -- purposes of legality checks and removal of ignored Ghost code.
21276 Mark_Ghost_Pragma
(N
, Ent
);
21278 if not Debug_Flag_U
then
21280 Set_Has_Pragma_Pure
(Ent
);
21282 if Legacy_Elaboration_Checks
then
21283 Set_Suppress_Elaboration_Warnings
(Ent
);
21288 -------------------
21289 -- Pure_Function --
21290 -------------------
21292 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21294 when Pragma_Pure_Function
=> Pure_Function
: declare
21295 Def_Id
: Entity_Id
;
21298 Effective
: Boolean := False;
21299 Orig_Def
: Entity_Id
;
21300 Same_Decl
: Boolean := False;
21304 Check_Arg_Count
(1);
21305 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21306 Check_Arg_Is_Local_Name
(Arg1
);
21307 E_Id
:= Get_Pragma_Arg
(Arg1
);
21309 if Etype
(E_Id
) = Any_Type
then
21313 -- Loop through homonyms (overloadings) of referenced entity
21315 E
:= Entity
(E_Id
);
21317 -- A pragma that applies to a Ghost entity becomes Ghost for the
21318 -- purposes of legality checks and removal of ignored Ghost code.
21320 Mark_Ghost_Pragma
(N
, E
);
21322 if Present
(E
) then
21324 Def_Id
:= Get_Base_Subprogram
(E
);
21326 if not Ekind_In
(Def_Id
, E_Function
,
21327 E_Generic_Function
,
21331 ("pragma% requires a function name", Arg1
);
21334 -- When we have a generic function we must jump up a level
21335 -- to the declaration of the wrapper package itself.
21337 Orig_Def
:= Def_Id
;
21339 if Is_Generic_Instance
(Def_Id
) then
21340 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
21341 Orig_Def
:= Parent
(Orig_Def
);
21345 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
21347 Set_Is_Pure
(Def_Id
);
21349 if not Has_Pragma_Pure_Function
(Def_Id
) then
21350 Set_Has_Pragma_Pure_Function
(Def_Id
);
21355 exit when From_Aspect_Specification
(N
);
21357 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
21361 and then Warn_On_Redundant_Constructs
21364 ("pragma Pure_Function on& is redundant?r?",
21367 elsif not Same_Decl
then
21369 ("pragma% argument must be in same declarative part",
21375 --------------------
21376 -- Queuing_Policy --
21377 --------------------
21379 -- pragma Queuing_Policy (policy_IDENTIFIER);
21381 when Pragma_Queuing_Policy
=> declare
21385 Check_Ada_83_Warning
;
21386 Check_Arg_Count
(1);
21387 Check_No_Identifiers
;
21388 Check_Arg_Is_Queuing_Policy
(Arg1
);
21389 Check_Valid_Configuration_Pragma
;
21390 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21391 QP
:= Fold_Upper
(Name_Buffer
(1));
21393 if Queuing_Policy
/= ' '
21394 and then Queuing_Policy
/= QP
21396 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
21397 Error_Pragma
("queuing policy incompatible with policy#");
21399 -- Set new policy, but always preserve System_Location since we
21400 -- like the error message with the run time name.
21403 Queuing_Policy
:= QP
;
21405 if Queuing_Policy_Sloc
/= System_Location
then
21406 Queuing_Policy_Sloc
:= Loc
;
21415 -- pragma Rational, for compatibility with foreign compiler
21417 when Pragma_Rational
=>
21418 Set_Rational_Profile
;
21420 ---------------------
21421 -- Refined_Depends --
21422 ---------------------
21424 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21426 -- DEPENDENCY_RELATION ::=
21428 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21430 -- DEPENDENCY_CLAUSE ::=
21431 -- OUTPUT_LIST =>[+] INPUT_LIST
21432 -- | NULL_DEPENDENCY_CLAUSE
21434 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21436 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21438 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21440 -- OUTPUT ::= NAME | FUNCTION_RESULT
21443 -- where FUNCTION_RESULT is a function Result attribute_reference
21445 -- Characteristics:
21447 -- * Analysis - The annotation undergoes initial checks to verify
21448 -- the legal placement and context. Secondary checks fully analyze
21449 -- the dependency clauses/global list in:
21451 -- Analyze_Refined_Depends_In_Decl_Part
21453 -- * Expansion - None.
21455 -- * Template - The annotation utilizes the generic template of the
21456 -- related subprogram body.
21458 -- * Globals - Capture of global references must occur after full
21461 -- * Instance - The annotation is instantiated automatically when
21462 -- the related generic subprogram body is instantiated.
21464 when Pragma_Refined_Depends
=> Refined_Depends
: declare
21465 Body_Id
: Entity_Id
;
21467 Spec_Id
: Entity_Id
;
21470 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21474 -- Chain the pragma on the contract for further processing by
21475 -- Analyze_Refined_Depends_In_Decl_Part.
21477 Add_Contract_Item
(N
, Body_Id
);
21479 -- The legality checks of pragmas Refined_Depends and
21480 -- Refined_Global are affected by the SPARK mode in effect and
21481 -- the volatility of the context. In addition these two pragmas
21482 -- are subject to an inherent order:
21484 -- 1) Refined_Global
21485 -- 2) Refined_Depends
21487 -- Analyze all these pragmas in the order outlined above
21489 Analyze_If_Present
(Pragma_SPARK_Mode
);
21490 Analyze_If_Present
(Pragma_Volatile_Function
);
21491 Analyze_If_Present
(Pragma_Refined_Global
);
21492 Analyze_Refined_Depends_In_Decl_Part
(N
);
21494 end Refined_Depends
;
21496 --------------------
21497 -- Refined_Global --
21498 --------------------
21500 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21502 -- GLOBAL_SPECIFICATION ::=
21505 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21507 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21509 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21510 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21511 -- GLOBAL_ITEM ::= NAME
21513 -- Characteristics:
21515 -- * Analysis - The annotation undergoes initial checks to verify
21516 -- the legal placement and context. Secondary checks fully analyze
21517 -- the dependency clauses/global list in:
21519 -- Analyze_Refined_Global_In_Decl_Part
21521 -- * Expansion - None.
21523 -- * Template - The annotation utilizes the generic template of the
21524 -- related subprogram body.
21526 -- * Globals - Capture of global references must occur after full
21529 -- * Instance - The annotation is instantiated automatically when
21530 -- the related generic subprogram body is instantiated.
21532 when Pragma_Refined_Global
=> Refined_Global
: declare
21533 Body_Id
: Entity_Id
;
21535 Spec_Id
: Entity_Id
;
21538 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21542 -- Chain the pragma on the contract for further processing by
21543 -- Analyze_Refined_Global_In_Decl_Part.
21545 Add_Contract_Item
(N
, Body_Id
);
21547 -- The legality checks of pragmas Refined_Depends and
21548 -- Refined_Global are affected by the SPARK mode in effect and
21549 -- the volatility of the context. In addition these two pragmas
21550 -- are subject to an inherent order:
21552 -- 1) Refined_Global
21553 -- 2) Refined_Depends
21555 -- Analyze all these pragmas in the order outlined above
21557 Analyze_If_Present
(Pragma_SPARK_Mode
);
21558 Analyze_If_Present
(Pragma_Volatile_Function
);
21559 Analyze_Refined_Global_In_Decl_Part
(N
);
21560 Analyze_If_Present
(Pragma_Refined_Depends
);
21562 end Refined_Global
;
21568 -- pragma Refined_Post (boolean_EXPRESSION);
21570 -- Characteristics:
21572 -- * Analysis - The annotation is fully analyzed immediately upon
21573 -- elaboration as it cannot forward reference entities.
21575 -- * Expansion - The annotation is expanded during the expansion of
21576 -- the related subprogram body contract as performed in:
21578 -- Expand_Subprogram_Contract
21580 -- * Template - The annotation utilizes the generic template of the
21581 -- related subprogram body.
21583 -- * Globals - Capture of global references must occur after full
21586 -- * Instance - The annotation is instantiated automatically when
21587 -- the related generic subprogram body is instantiated.
21589 when Pragma_Refined_Post
=> Refined_Post
: declare
21590 Body_Id
: Entity_Id
;
21592 Spec_Id
: Entity_Id
;
21595 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21597 -- Fully analyze the pragma when it appears inside a subprogram
21598 -- body because it cannot benefit from forward references.
21602 -- Chain the pragma on the contract for completeness
21604 Add_Contract_Item
(N
, Body_Id
);
21606 -- The legality checks of pragma Refined_Post are affected by
21607 -- the SPARK mode in effect and the volatility of the context.
21608 -- Analyze all pragmas in a specific order.
21610 Analyze_If_Present
(Pragma_SPARK_Mode
);
21611 Analyze_If_Present
(Pragma_Volatile_Function
);
21612 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
21614 -- Currently it is not possible to inline pre/postconditions on
21615 -- a subprogram subject to pragma Inline_Always.
21617 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
21621 -------------------
21622 -- Refined_State --
21623 -------------------
21625 -- pragma Refined_State (REFINEMENT_LIST);
21627 -- REFINEMENT_LIST ::=
21628 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
21630 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
21632 -- CONSTITUENT_LIST ::=
21635 -- | (CONSTITUENT {, CONSTITUENT})
21637 -- CONSTITUENT ::= object_NAME | state_NAME
21639 -- Characteristics:
21641 -- * Analysis - The annotation undergoes initial checks to verify
21642 -- the legal placement and context. Secondary checks preanalyze the
21643 -- refinement clauses in:
21645 -- Analyze_Refined_State_In_Decl_Part
21647 -- * Expansion - None.
21649 -- * Template - The annotation utilizes the template of the related
21652 -- * Globals - Capture of global references must occur after full
21655 -- * Instance - The annotation is instantiated automatically when
21656 -- the related generic package body is instantiated.
21658 when Pragma_Refined_State
=> Refined_State
: declare
21659 Pack_Decl
: Node_Id
;
21660 Spec_Id
: Entity_Id
;
21664 Check_No_Identifiers
;
21665 Check_Arg_Count
(1);
21667 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
21669 if Nkind
(Pack_Decl
) /= N_Package_Body
then
21674 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
21676 -- A pragma that applies to a Ghost entity becomes Ghost for the
21677 -- purposes of legality checks and removal of ignored Ghost code.
21679 Mark_Ghost_Pragma
(N
, Spec_Id
);
21681 -- Chain the pragma on the contract for further processing by
21682 -- Analyze_Refined_State_In_Decl_Part.
21684 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
21686 -- The legality checks of pragma Refined_State are affected by the
21687 -- SPARK mode in effect. Analyze all pragmas in a specific order.
21689 Analyze_If_Present
(Pragma_SPARK_Mode
);
21691 -- State refinement is allowed only when the corresponding package
21692 -- declaration has non-null pragma Abstract_State. Refinement not
21693 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
21695 if SPARK_Mode
/= Off
21697 (No
(Abstract_States
(Spec_Id
))
21698 or else Has_Null_Abstract_State
(Spec_Id
))
21701 ("useless refinement, package & does not define abstract "
21702 & "states", N
, Spec_Id
);
21707 -----------------------
21708 -- Relative_Deadline --
21709 -----------------------
21711 -- pragma Relative_Deadline (time_span_EXPRESSION);
21713 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
21714 P
: constant Node_Id
:= Parent
(N
);
21719 Check_No_Identifiers
;
21720 Check_Arg_Count
(1);
21722 Arg
:= Get_Pragma_Arg
(Arg1
);
21724 -- The expression must be analyzed in the special manner described
21725 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
21727 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
21731 if Nkind
(P
) = N_Subprogram_Body
then
21732 Check_In_Main_Program
;
21734 -- Only Task and subprogram cases allowed
21736 elsif Nkind
(P
) /= N_Task_Definition
then
21740 -- Check duplicate pragma before we set the corresponding flag
21742 if Has_Relative_Deadline_Pragma
(P
) then
21743 Error_Pragma
("duplicate pragma% not allowed");
21746 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
21747 -- Relative_Deadline pragma node cannot be inserted in the Rep
21748 -- Item chain of Ent since it is rewritten by the expander as a
21749 -- procedure call statement that will break the chain.
21751 Set_Has_Relative_Deadline_Pragma
(P
);
21752 end Relative_Deadline
;
21754 ------------------------
21755 -- Remote_Access_Type --
21756 ------------------------
21758 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
21760 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
21765 Check_Arg_Count
(1);
21766 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21767 Check_Arg_Is_Local_Name
(Arg1
);
21769 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
21771 -- A pragma that applies to a Ghost entity becomes Ghost for the
21772 -- purposes of legality checks and removal of ignored Ghost code.
21774 Mark_Ghost_Pragma
(N
, E
);
21776 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
21777 and then Ekind
(E
) = E_General_Access_Type
21778 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
21779 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
21781 and then Is_Valid_Remote_Object_Type
21782 (Root_Type
(Directly_Designated_Type
(E
)))
21784 Set_Is_Remote_Types
(E
);
21788 ("pragma% applies only to formal access-to-class-wide types",
21791 end Remote_Access_Type
;
21793 ---------------------------
21794 -- Remote_Call_Interface --
21795 ---------------------------
21797 -- pragma Remote_Call_Interface [(library_unit_NAME)];
21799 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
21800 Cunit_Node
: Node_Id
;
21801 Cunit_Ent
: Entity_Id
;
21805 Check_Ada_83_Warning
;
21806 Check_Valid_Library_Unit_Pragma
;
21808 if Nkind
(N
) = N_Null_Statement
then
21812 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21813 K
:= Nkind
(Unit
(Cunit_Node
));
21814 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21816 -- A pragma that applies to a Ghost entity becomes Ghost for the
21817 -- purposes of legality checks and removal of ignored Ghost code.
21819 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21821 if K
= N_Package_Declaration
21822 or else K
= N_Generic_Package_Declaration
21823 or else K
= N_Subprogram_Declaration
21824 or else K
= N_Generic_Subprogram_Declaration
21825 or else (K
= N_Subprogram_Body
21826 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
21831 "pragma% must apply to package or subprogram declaration");
21834 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
21835 end Remote_Call_Interface
;
21841 -- pragma Remote_Types [(library_unit_NAME)];
21843 when Pragma_Remote_Types
=> Remote_Types
: declare
21844 Cunit_Node
: Node_Id
;
21845 Cunit_Ent
: Entity_Id
;
21848 Check_Ada_83_Warning
;
21849 Check_Valid_Library_Unit_Pragma
;
21851 if Nkind
(N
) = N_Null_Statement
then
21855 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21856 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21858 -- A pragma that applies to a Ghost entity becomes Ghost for the
21859 -- purposes of legality checks and removal of ignored Ghost code.
21861 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21863 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21864 N_Generic_Package_Declaration
)
21867 ("pragma% can only apply to a package declaration");
21870 Set_Is_Remote_Types
(Cunit_Ent
);
21877 -- pragma Ravenscar;
21879 when Pragma_Ravenscar
=>
21881 Check_Arg_Count
(0);
21882 Check_Valid_Configuration_Pragma
;
21883 Set_Ravenscar_Profile
(Ravenscar
, N
);
21885 if Warn_On_Obsolescent_Feature
then
21887 ("pragma Ravenscar is an obsolescent feature?j?", N
);
21889 ("|use pragma Profile (Ravenscar) instead?j?", N
);
21892 -------------------------
21893 -- Restricted_Run_Time --
21894 -------------------------
21896 -- pragma Restricted_Run_Time;
21898 when Pragma_Restricted_Run_Time
=>
21900 Check_Arg_Count
(0);
21901 Check_Valid_Configuration_Pragma
;
21902 Set_Profile_Restrictions
21903 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
21905 if Warn_On_Obsolescent_Feature
then
21907 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21910 ("|use pragma Profile (Restricted) instead?j?", N
);
21917 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21920 -- restriction_IDENTIFIER
21921 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21923 when Pragma_Restrictions
=>
21924 Process_Restrictions_Or_Restriction_Warnings
21925 (Warn
=> Treat_Restrictions_As_Warnings
);
21927 --------------------------
21928 -- Restriction_Warnings --
21929 --------------------------
21931 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21934 -- restriction_IDENTIFIER
21935 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21937 when Pragma_Restriction_Warnings
=>
21939 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
21945 -- pragma Reviewable;
21947 when Pragma_Reviewable
=>
21948 Check_Ada_83_Warning
;
21949 Check_Arg_Count
(0);
21951 -- Call dummy debugging function rv. This is done to assist front
21952 -- end debugging. By placing a Reviewable pragma in the source
21953 -- program, a breakpoint on rv catches this place in the source,
21954 -- allowing convenient stepping to the point of interest.
21958 --------------------------
21959 -- Secondary_Stack_Size --
21960 --------------------------
21962 -- pragma Secondary_Stack_Size (EXPRESSION);
21964 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
21965 P
: constant Node_Id
:= Parent
(N
);
21971 Check_No_Identifiers
;
21972 Check_Arg_Count
(1);
21974 if Nkind
(P
) = N_Task_Definition
then
21975 Arg
:= Get_Pragma_Arg
(Arg1
);
21976 Ent
:= Defining_Identifier
(Parent
(P
));
21978 -- The expression must be analyzed in the special manner
21979 -- described in "Handling of Default Expressions" in sem.ads.
21981 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21983 -- The pragma cannot appear if the No_Secondary_Stack
21984 -- restriction is in effect.
21986 Check_Restriction
(No_Secondary_Stack
, Arg
);
21988 -- Anything else is incorrect
21994 -- Check duplicate pragma before we chain the pragma in the Rep
21995 -- Item chain of Ent.
21997 Check_Duplicate_Pragma
(Ent
);
21998 Record_Rep_Item
(Ent
, N
);
21999 end Secondary_Stack_Size
;
22001 --------------------------
22002 -- Short_Circuit_And_Or --
22003 --------------------------
22005 -- pragma Short_Circuit_And_Or;
22007 when Pragma_Short_Circuit_And_Or
=>
22009 Check_Arg_Count
(0);
22010 Check_Valid_Configuration_Pragma
;
22011 Short_Circuit_And_Or
:= True;
22013 -------------------
22014 -- Share_Generic --
22015 -------------------
22017 -- pragma Share_Generic (GNAME {, GNAME});
22019 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22021 when Pragma_Share_Generic
=>
22023 Process_Generic_List
;
22029 -- pragma Shared (LOCAL_NAME);
22031 when Pragma_Shared
=>
22033 Process_Atomic_Independent_Shared_Volatile
;
22035 --------------------
22036 -- Shared_Passive --
22037 --------------------
22039 -- pragma Shared_Passive [(library_unit_NAME)];
22041 -- Set the flag Is_Shared_Passive of program unit name entity
22043 when Pragma_Shared_Passive
=> Shared_Passive
: declare
22044 Cunit_Node
: Node_Id
;
22045 Cunit_Ent
: Entity_Id
;
22048 Check_Ada_83_Warning
;
22049 Check_Valid_Library_Unit_Pragma
;
22051 if Nkind
(N
) = N_Null_Statement
then
22055 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22056 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22058 -- A pragma that applies to a Ghost entity becomes Ghost for the
22059 -- purposes of legality checks and removal of ignored Ghost code.
22061 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22063 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22064 N_Generic_Package_Declaration
)
22067 ("pragma% can only apply to a package declaration");
22070 Set_Is_Shared_Passive
(Cunit_Ent
);
22071 end Shared_Passive
;
22073 -----------------------
22074 -- Short_Descriptors --
22075 -----------------------
22077 -- pragma Short_Descriptors;
22079 -- Recognize and validate, but otherwise ignore
22081 when Pragma_Short_Descriptors
=>
22083 Check_Arg_Count
(0);
22084 Check_Valid_Configuration_Pragma
;
22086 ------------------------------
22087 -- Simple_Storage_Pool_Type --
22088 ------------------------------
22090 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22092 when Pragma_Simple_Storage_Pool_Type
=>
22093 Simple_Storage_Pool_Type
: declare
22099 Check_Arg_Count
(1);
22100 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22102 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22103 Find_Type
(Type_Id
);
22104 Typ
:= Entity
(Type_Id
);
22106 if Typ
= Any_Type
then
22110 -- A pragma that applies to a Ghost entity becomes Ghost for the
22111 -- purposes of legality checks and removal of ignored Ghost code.
22113 Mark_Ghost_Pragma
(N
, Typ
);
22115 -- We require the pragma to apply to a type declared in a package
22116 -- declaration, but not (immediately) within a package body.
22118 if Ekind
(Current_Scope
) /= E_Package
22119 or else In_Package_Body
(Current_Scope
)
22122 ("pragma% can only apply to type declared immediately "
22123 & "within a package declaration");
22126 -- A simple storage pool type must be an immutably limited record
22127 -- or private type. If the pragma is given for a private type,
22128 -- the full type is similarly restricted (which is checked later
22129 -- in Freeze_Entity).
22131 if Is_Record_Type
(Typ
)
22132 and then not Is_Limited_View
(Typ
)
22135 ("pragma% can only apply to explicitly limited record type");
22137 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
22139 ("pragma% can only apply to a private type that is limited");
22141 elsif not Is_Record_Type
(Typ
)
22142 and then not Is_Private_Type
(Typ
)
22145 ("pragma% can only apply to limited record or private type");
22148 Record_Rep_Item
(Typ
, N
);
22149 end Simple_Storage_Pool_Type
;
22151 ----------------------
22152 -- Source_File_Name --
22153 ----------------------
22155 -- There are five forms for this pragma:
22157 -- pragma Source_File_Name (
22158 -- [UNIT_NAME =>] unit_NAME,
22159 -- BODY_FILE_NAME => STRING_LITERAL
22160 -- [, [INDEX =>] INTEGER_LITERAL]);
22162 -- pragma Source_File_Name (
22163 -- [UNIT_NAME =>] unit_NAME,
22164 -- SPEC_FILE_NAME => STRING_LITERAL
22165 -- [, [INDEX =>] INTEGER_LITERAL]);
22167 -- pragma Source_File_Name (
22168 -- BODY_FILE_NAME => STRING_LITERAL
22169 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22170 -- [, CASING => CASING_SPEC]);
22172 -- pragma Source_File_Name (
22173 -- SPEC_FILE_NAME => STRING_LITERAL
22174 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22175 -- [, CASING => CASING_SPEC]);
22177 -- pragma Source_File_Name (
22178 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22179 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22180 -- [, CASING => CASING_SPEC]);
22182 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22184 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22185 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22186 -- only be used when no project file is used, while SFNP can only be
22187 -- used when a project file is used.
22189 -- No processing here. Processing was completed during parsing, since
22190 -- we need to have file names set as early as possible. Units are
22191 -- loaded well before semantic processing starts.
22193 -- The only processing we defer to this point is the check for
22194 -- correct placement.
22196 when Pragma_Source_File_Name
=>
22198 Check_Valid_Configuration_Pragma
;
22200 ------------------------------
22201 -- Source_File_Name_Project --
22202 ------------------------------
22204 -- See Source_File_Name for syntax
22206 -- No processing here. Processing was completed during parsing, since
22207 -- we need to have file names set as early as possible. Units are
22208 -- loaded well before semantic processing starts.
22210 -- The only processing we defer to this point is the check for
22211 -- correct placement.
22213 when Pragma_Source_File_Name_Project
=>
22215 Check_Valid_Configuration_Pragma
;
22217 -- Check that a pragma Source_File_Name_Project is used only in a
22218 -- configuration pragmas file.
22220 -- Pragmas Source_File_Name_Project should only be generated by
22221 -- the Project Manager in configuration pragmas files.
22223 -- This is really an ugly test. It seems to depend on some
22224 -- accidental and undocumented property. At the very least it
22225 -- needs to be documented, but it would be better to have a
22226 -- clean way of testing if we are in a configuration file???
22228 if Present
(Parent
(N
)) then
22230 ("pragma% can only appear in a configuration pragmas file");
22233 ----------------------
22234 -- Source_Reference --
22235 ----------------------
22237 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22239 -- Nothing to do, all processing completed in Par.Prag, since we need
22240 -- the information for possible parser messages that are output.
22242 when Pragma_Source_Reference
=>
22249 -- pragma SPARK_Mode [(On | Off)];
22251 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
22252 Mode_Id
: SPARK_Mode_Type
;
22254 procedure Check_Pragma_Conformance
22255 (Context_Pragma
: Node_Id
;
22256 Entity
: Entity_Id
;
22257 Entity_Pragma
: Node_Id
);
22258 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22259 -- conformance of pragma N depending the following scenarios:
22261 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22262 -- compatible with the pragma Context_Pragma that was inherited
22263 -- from the context:
22264 -- * If the mode of Context_Pragma is ON, then the new mode can
22266 -- * If the mode of Context_Pragma is OFF, then the only allowed
22267 -- new mode is also OFF. Emit error if this is not the case.
22269 -- If Entity is not Empty, verify that pragma N is compatible with
22270 -- pragma Entity_Pragma that belongs to Entity.
22271 -- * If Entity_Pragma is Empty, always issue an error as this
22272 -- corresponds to the case where a previous section of Entity
22273 -- has no SPARK_Mode set.
22274 -- * If the mode of Entity_Pragma is ON, then the new mode can
22276 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22277 -- new mode is also OFF. Emit error if this is not the case.
22279 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
22280 -- Subsidiary to routines Process_xxx. Verify that the related
22281 -- entity E subject to pragma SPARK_Mode is library-level.
22283 procedure Process_Body
(Decl
: Node_Id
);
22284 -- Verify the legality of pragma SPARK_Mode when it appears as the
22285 -- top of the body declarations of entry, package, protected unit,
22286 -- subprogram or task unit body denoted by Decl.
22288 procedure Process_Overloadable
(Decl
: Node_Id
);
22289 -- Verify the legality of pragma SPARK_Mode when it applies to an
22290 -- entry or [generic] subprogram declaration denoted by Decl.
22292 procedure Process_Private_Part
(Decl
: Node_Id
);
22293 -- Verify the legality of pragma SPARK_Mode when it appears at the
22294 -- top of the private declarations of a package spec, protected or
22295 -- task unit declaration denoted by Decl.
22297 procedure Process_Statement_Part
(Decl
: Node_Id
);
22298 -- Verify the legality of pragma SPARK_Mode when it appears at the
22299 -- top of the statement sequence of a package body denoted by node
22302 procedure Process_Visible_Part
(Decl
: Node_Id
);
22303 -- Verify the legality of pragma SPARK_Mode when it appears at the
22304 -- top of the visible declarations of a package spec, protected or
22305 -- task unit declaration denoted by Decl. The routine is also used
22306 -- on protected or task units declared without a definition.
22308 procedure Set_SPARK_Context
;
22309 -- Subsidiary to routines Process_xxx. Set the global variables
22310 -- which represent the mode of the context from pragma N. Ensure
22311 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22313 ------------------------------
22314 -- Check_Pragma_Conformance --
22315 ------------------------------
22317 procedure Check_Pragma_Conformance
22318 (Context_Pragma
: Node_Id
;
22319 Entity
: Entity_Id
;
22320 Entity_Pragma
: Node_Id
)
22322 Err_Id
: Entity_Id
;
22326 -- The current pragma may appear without an argument. If this
22327 -- is the case, associate all error messages with the pragma
22330 if Present
(Arg1
) then
22336 -- The mode of the current pragma is compared against that of
22337 -- an enclosing context.
22339 if Present
(Context_Pragma
) then
22340 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
22342 -- Issue an error if the new mode is less restrictive than
22343 -- that of the context.
22345 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
22346 and then Get_SPARK_Mode_From_Annotation
(N
) = On
22349 ("cannot change SPARK_Mode from Off to On", Err_N
);
22350 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
22351 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
22356 -- The mode of the current pragma is compared against that of
22357 -- an initial package, protected type, subprogram or task type
22360 if Present
(Entity
) then
22362 -- A simple protected or task type is transformed into an
22363 -- anonymous type whose name cannot be used to issue error
22364 -- messages. Recover the original entity of the type.
22366 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
22369 (Original_Node
(Unit_Declaration_Node
(Entity
)));
22374 -- Both the initial declaration and the completion carry
22375 -- SPARK_Mode pragmas.
22377 if Present
(Entity_Pragma
) then
22378 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
22380 -- Issue an error if the new mode is less restrictive
22381 -- than that of the initial declaration.
22383 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
22384 and then Get_SPARK_Mode_From_Annotation
(N
) = On
22386 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
22387 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
22389 ("\value Off was set for SPARK_Mode on&#",
22394 -- Otherwise the initial declaration lacks a SPARK_Mode
22395 -- pragma in which case the current pragma is illegal as
22396 -- it cannot "complete".
22399 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
22400 Error_Msg_Sloc
:= Sloc
(Err_Id
);
22402 ("\no value was set for SPARK_Mode on&#",
22407 end Check_Pragma_Conformance
;
22409 --------------------------------
22410 -- Check_Library_Level_Entity --
22411 --------------------------------
22413 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
22414 procedure Add_Entity_To_Name_Buffer
;
22415 -- Add the E_Kind of entity E to the name buffer
22417 -------------------------------
22418 -- Add_Entity_To_Name_Buffer --
22419 -------------------------------
22421 procedure Add_Entity_To_Name_Buffer
is
22423 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
22424 Add_Str_To_Name_Buffer
("entry");
22426 elsif Ekind_In
(E
, E_Generic_Package
,
22430 Add_Str_To_Name_Buffer
("package");
22432 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
22433 Add_Str_To_Name_Buffer
("protected type");
22435 elsif Ekind_In
(E
, E_Function
,
22436 E_Generic_Function
,
22437 E_Generic_Procedure
,
22441 Add_Str_To_Name_Buffer
("subprogram");
22444 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
22445 Add_Str_To_Name_Buffer
("task type");
22447 end Add_Entity_To_Name_Buffer
;
22451 Msg_1
: constant String := "incorrect placement of pragma%";
22454 -- Start of processing for Check_Library_Level_Entity
22457 if not Is_Library_Level_Entity
(E
) then
22458 Error_Msg_Name_1
:= Pname
;
22459 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
22462 Add_Str_To_Name_Buffer
("\& is not a library-level ");
22463 Add_Entity_To_Name_Buffer
;
22465 Msg_2
:= Name_Find
;
22466 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
22470 end Check_Library_Level_Entity
;
22476 procedure Process_Body
(Decl
: Node_Id
) is
22477 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22478 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
22481 -- Ignore pragma when applied to the special body created for
22482 -- inlining, recognized by its internal name _Parent.
22484 if Chars
(Body_Id
) = Name_uParent
then
22488 Check_Library_Level_Entity
(Body_Id
);
22490 -- For entry bodies, verify the legality against:
22491 -- * The mode of the context
22492 -- * The mode of the spec (if any)
22494 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
22496 -- A stand-alone subprogram body
22498 if Body_Id
= Spec_Id
then
22499 Check_Pragma_Conformance
22500 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22502 Entity_Pragma
=> Empty
);
22504 -- An entry or subprogram body that completes a previous
22508 Check_Pragma_Conformance
22509 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22511 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22515 Set_SPARK_Pragma
(Body_Id
, N
);
22516 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22518 -- For package bodies, verify the legality against:
22519 -- * The mode of the context
22520 -- * The mode of the private part
22522 -- This case is separated from protected and task bodies
22523 -- because the statement part of the package body inherits
22524 -- the mode of the body declarations.
22526 elsif Nkind
(Decl
) = N_Package_Body
then
22527 Check_Pragma_Conformance
22528 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22530 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22533 Set_SPARK_Pragma
(Body_Id
, N
);
22534 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22535 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22536 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
22538 -- For protected and task bodies, verify the legality against:
22539 -- * The mode of the context
22540 -- * The mode of the private part
22544 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
22546 Check_Pragma_Conformance
22547 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22549 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22552 Set_SPARK_Pragma
(Body_Id
, N
);
22553 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22557 --------------------------
22558 -- Process_Overloadable --
22559 --------------------------
22561 procedure Process_Overloadable
(Decl
: Node_Id
) is
22562 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22563 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
22566 Check_Library_Level_Entity
(Spec_Id
);
22568 -- Verify the legality against:
22569 -- * The mode of the context
22571 Check_Pragma_Conformance
22572 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22574 Entity_Pragma
=> Empty
);
22576 Set_SPARK_Pragma
(Spec_Id
, N
);
22577 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22579 -- When the pragma applies to the anonymous object created for
22580 -- a single task type, decorate the type as well. This scenario
22581 -- arises when the single task type lacks a task definition,
22582 -- therefore there is no issue with respect to a potential
22583 -- pragma SPARK_Mode in the private part.
22585 -- task type Anon_Task_Typ;
22586 -- Obj : Anon_Task_Typ;
22587 -- pragma SPARK_Mode ...;
22589 if Is_Single_Task_Object
(Spec_Id
) then
22590 Set_SPARK_Pragma
(Spec_Typ
, N
);
22591 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
22592 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
22593 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
22595 end Process_Overloadable
;
22597 --------------------------
22598 -- Process_Private_Part --
22599 --------------------------
22601 procedure Process_Private_Part
(Decl
: Node_Id
) is
22602 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22605 Check_Library_Level_Entity
(Spec_Id
);
22607 -- Verify the legality against:
22608 -- * The mode of the visible declarations
22610 Check_Pragma_Conformance
22611 (Context_Pragma
=> Empty
,
22613 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22616 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22617 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
22618 end Process_Private_Part
;
22620 ----------------------------
22621 -- Process_Statement_Part --
22622 ----------------------------
22624 procedure Process_Statement_Part
(Decl
: Node_Id
) is
22625 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22628 Check_Library_Level_Entity
(Body_Id
);
22630 -- Verify the legality against:
22631 -- * The mode of the body declarations
22633 Check_Pragma_Conformance
22634 (Context_Pragma
=> Empty
,
22636 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
22639 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22640 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
22641 end Process_Statement_Part
;
22643 --------------------------
22644 -- Process_Visible_Part --
22645 --------------------------
22647 procedure Process_Visible_Part
(Decl
: Node_Id
) is
22648 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22649 Obj_Id
: Entity_Id
;
22652 Check_Library_Level_Entity
(Spec_Id
);
22654 -- Verify the legality against:
22655 -- * The mode of the context
22657 Check_Pragma_Conformance
22658 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22660 Entity_Pragma
=> Empty
);
22662 -- A task unit declared without a definition does not set the
22663 -- SPARK_Mode of the context because the task does not have any
22664 -- entries that could inherit the mode.
22666 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
22667 N_Task_Type_Declaration
)
22672 Set_SPARK_Pragma
(Spec_Id
, N
);
22673 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22674 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22675 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
22677 -- When the pragma applies to a single protected or task type,
22678 -- decorate the corresponding anonymous object as well.
22680 -- protected Anon_Prot_Typ is
22681 -- pragma SPARK_Mode ...;
22683 -- end Anon_Prot_Typ;
22685 -- Obj : Anon_Prot_Typ;
22687 if Is_Single_Concurrent_Type
(Spec_Id
) then
22688 Obj_Id
:= Anonymous_Object
(Spec_Id
);
22690 Set_SPARK_Pragma
(Obj_Id
, N
);
22691 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
22693 end Process_Visible_Part
;
22695 -----------------------
22696 -- Set_SPARK_Context --
22697 -----------------------
22699 procedure Set_SPARK_Context
is
22701 SPARK_Mode
:= Mode_Id
;
22702 SPARK_Mode_Pragma
:= N
;
22703 end Set_SPARK_Context
;
22711 -- Start of processing for Do_SPARK_Mode
22714 -- When a SPARK_Mode pragma appears inside an instantiation whose
22715 -- enclosing context has SPARK_Mode set to "off", the pragma has
22716 -- no semantic effect.
22718 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
22719 Rewrite
(N
, Make_Null_Statement
(Loc
));
22725 Check_No_Identifiers
;
22726 Check_At_Most_N_Arguments
(1);
22728 -- Check the legality of the mode (no argument = ON)
22730 if Arg_Count
= 1 then
22731 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22732 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
22737 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
22738 Context
:= Parent
(N
);
22740 -- The pragma appears in a configuration file
22742 if No
(Context
) then
22743 Check_Valid_Configuration_Pragma
;
22745 if Present
(SPARK_Mode_Pragma
) then
22748 Prev
=> SPARK_Mode_Pragma
);
22754 -- The pragma acts as a configuration pragma in a compilation unit
22756 -- pragma SPARK_Mode ...;
22757 -- package Pack is ...;
22759 elsif Nkind
(Context
) = N_Compilation_Unit
22760 and then List_Containing
(N
) = Context_Items
(Context
)
22762 Check_Valid_Configuration_Pragma
;
22765 -- Otherwise the placement of the pragma within the tree dictates
22766 -- its associated construct. Inspect the declarative list where
22767 -- the pragma resides to find a potential construct.
22771 while Present
(Stmt
) loop
22773 -- Skip prior pragmas, but check for duplicates. Note that
22774 -- this also takes care of pragmas generated for aspects.
22776 if Nkind
(Stmt
) = N_Pragma
then
22777 if Pragma_Name
(Stmt
) = Pname
then
22784 -- The pragma applies to an expression function that has
22785 -- already been rewritten into a subprogram declaration.
22787 -- function Expr_Func return ... is (...);
22788 -- pragma SPARK_Mode ...;
22790 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
22791 and then Nkind
(Original_Node
(Stmt
)) =
22792 N_Expression_Function
22794 Process_Overloadable
(Stmt
);
22797 -- The pragma applies to the anonymous object created for a
22798 -- single concurrent type.
22800 -- protected type Anon_Prot_Typ ...;
22801 -- Obj : Anon_Prot_Typ;
22802 -- pragma SPARK_Mode ...;
22804 elsif Nkind
(Stmt
) = N_Object_Declaration
22805 and then Is_Single_Concurrent_Object
22806 (Defining_Entity
(Stmt
))
22808 Process_Overloadable
(Stmt
);
22811 -- Skip internally generated code
22813 elsif not Comes_From_Source
(Stmt
) then
22816 -- The pragma applies to an entry or [generic] subprogram
22820 -- pragma SPARK_Mode ...;
22823 -- procedure Proc ...;
22824 -- pragma SPARK_Mode ...;
22826 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
22827 N_Subprogram_Declaration
)
22828 or else (Nkind
(Stmt
) = N_Entry_Declaration
22829 and then Is_Protected_Type
22830 (Scope
(Defining_Entity
(Stmt
))))
22832 Process_Overloadable
(Stmt
);
22835 -- Otherwise the pragma does not apply to a legal construct
22836 -- or it does not appear at the top of a declarative or a
22837 -- statement list. Issue an error and stop the analysis.
22847 -- The pragma applies to a package or a subprogram that acts as
22848 -- a compilation unit.
22850 -- procedure Proc ...;
22851 -- pragma SPARK_Mode ...;
22853 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
22854 Context
:= Unit
(Parent
(Context
));
22857 -- The pragma appears at the top of entry, package, protected
22858 -- unit, subprogram or task unit body declarations.
22860 -- entry Ent when ... is
22861 -- pragma SPARK_Mode ...;
22863 -- package body Pack is
22864 -- pragma SPARK_Mode ...;
22866 -- procedure Proc ... is
22867 -- pragma SPARK_Mode;
22869 -- protected body Prot is
22870 -- pragma SPARK_Mode ...;
22872 if Nkind_In
(Context
, N_Entry_Body
,
22878 Process_Body
(Context
);
22880 -- The pragma appears at the top of the visible or private
22881 -- declaration of a package spec, protected or task unit.
22884 -- pragma SPARK_Mode ...;
22886 -- pragma SPARK_Mode ...;
22888 -- protected [type] Prot is
22889 -- pragma SPARK_Mode ...;
22891 -- pragma SPARK_Mode ...;
22893 elsif Nkind_In
(Context
, N_Package_Specification
,
22894 N_Protected_Definition
,
22897 if List_Containing
(N
) = Visible_Declarations
(Context
) then
22898 Process_Visible_Part
(Parent
(Context
));
22900 Process_Private_Part
(Parent
(Context
));
22903 -- The pragma appears at the top of package body statements
22905 -- package body Pack is
22907 -- pragma SPARK_Mode;
22909 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
22910 and then Nkind
(Parent
(Context
)) = N_Package_Body
22912 Process_Statement_Part
(Parent
(Context
));
22914 -- The pragma appeared as an aspect of a [generic] subprogram
22915 -- declaration that acts as a compilation unit.
22918 -- procedure Proc ...;
22919 -- pragma SPARK_Mode ...;
22921 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
22922 N_Subprogram_Declaration
)
22924 Process_Overloadable
(Context
);
22926 -- The pragma does not apply to a legal construct, issue error
22934 --------------------------------
22935 -- Static_Elaboration_Desired --
22936 --------------------------------
22938 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22940 when Pragma_Static_Elaboration_Desired
=>
22942 Check_At_Most_N_Arguments
(1);
22944 if Is_Compilation_Unit
(Current_Scope
)
22945 and then Ekind
(Current_Scope
) = E_Package
22947 Set_Static_Elaboration_Desired
(Current_Scope
, True);
22949 Error_Pragma
("pragma% must apply to a library-level package");
22956 -- pragma Storage_Size (EXPRESSION);
22958 when Pragma_Storage_Size
=> Storage_Size
: declare
22959 P
: constant Node_Id
:= Parent
(N
);
22963 Check_No_Identifiers
;
22964 Check_Arg_Count
(1);
22966 -- The expression must be analyzed in the special manner described
22967 -- in "Handling of Default Expressions" in sem.ads.
22969 Arg
:= Get_Pragma_Arg
(Arg1
);
22970 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22972 if not Is_OK_Static_Expression
(Arg
) then
22973 Check_Restriction
(Static_Storage_Size
, Arg
);
22976 if Nkind
(P
) /= N_Task_Definition
then
22981 if Has_Storage_Size_Pragma
(P
) then
22982 Error_Pragma
("duplicate pragma% not allowed");
22984 Set_Has_Storage_Size_Pragma
(P
, True);
22987 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22995 -- pragma Storage_Unit (NUMERIC_LITERAL);
22997 -- Only permitted argument is System'Storage_Unit value
22999 when Pragma_Storage_Unit
=>
23000 Check_No_Identifiers
;
23001 Check_Arg_Count
(1);
23002 Check_Arg_Is_Integer_Literal
(Arg1
);
23004 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
23005 UI_From_Int
(Ttypes
.System_Storage_Unit
)
23007 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
23009 ("the only allowed argument for pragma% is ^", Arg1
);
23012 --------------------
23013 -- Stream_Convert --
23014 --------------------
23016 -- pragma Stream_Convert (
23017 -- [Entity =>] type_LOCAL_NAME,
23018 -- [Read =>] function_NAME,
23019 -- [Write =>] function NAME);
23021 when Pragma_Stream_Convert
=> Stream_Convert
: declare
23022 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
23023 -- Check that the given argument is the name of a local function
23024 -- of one argument that is not overloaded earlier in the current
23025 -- local scope. A check is also made that the argument is a
23026 -- function with one parameter.
23028 --------------------------------------
23029 -- Check_OK_Stream_Convert_Function --
23030 --------------------------------------
23032 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
23036 Check_Arg_Is_Local_Name
(Arg
);
23037 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
23039 if Has_Homonym
(Ent
) then
23041 ("argument for pragma% may not be overloaded", Arg
);
23044 if Ekind
(Ent
) /= E_Function
23045 or else No
(First_Formal
(Ent
))
23046 or else Present
(Next_Formal
(First_Formal
(Ent
)))
23049 ("argument for pragma% must be function of one argument",
23052 end Check_OK_Stream_Convert_Function
;
23054 -- Start of processing for Stream_Convert
23058 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
23059 Check_Arg_Count
(3);
23060 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23061 Check_Optional_Identifier
(Arg2
, Name_Read
);
23062 Check_Optional_Identifier
(Arg3
, Name_Write
);
23063 Check_Arg_Is_Local_Name
(Arg1
);
23064 Check_OK_Stream_Convert_Function
(Arg2
);
23065 Check_OK_Stream_Convert_Function
(Arg3
);
23068 Typ
: constant Entity_Id
:=
23069 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
23070 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
23071 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
23074 Check_First_Subtype
(Arg1
);
23076 -- Check for too early or too late. Note that we don't enforce
23077 -- the rule about primitive operations in this case, since, as
23078 -- is the case for explicit stream attributes themselves, these
23079 -- restrictions are not appropriate. Note that the chaining of
23080 -- the pragma by Rep_Item_Too_Late is actually the critical
23081 -- processing done for this pragma.
23083 if Rep_Item_Too_Early
(Typ
, N
)
23085 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
23090 -- Return if previous error
23092 if Etype
(Typ
) = Any_Type
23094 Etype
(Read
) = Any_Type
23096 Etype
(Write
) = Any_Type
23103 if Underlying_Type
(Etype
(Read
)) /= Typ
then
23105 ("incorrect return type for function&", Arg2
);
23108 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
23110 ("incorrect parameter type for function&", Arg3
);
23113 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
23114 Underlying_Type
(Etype
(Write
))
23117 ("result type of & does not match Read parameter type",
23121 end Stream_Convert
;
23127 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23129 -- This is processed by the parser since some of the style checks
23130 -- take place during source scanning and parsing. This means that
23131 -- we don't need to issue error messages here.
23133 when Pragma_Style_Checks
=> Style_Checks
: declare
23134 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23140 Check_No_Identifiers
;
23142 -- Two argument form
23144 if Arg_Count
= 2 then
23145 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23152 E_Id
:= Get_Pragma_Arg
(Arg2
);
23155 if not Is_Entity_Name
(E_Id
) then
23157 ("second argument of pragma% must be entity name",
23161 E
:= Entity
(E_Id
);
23163 if not Ignore_Style_Checks_Pragmas
then
23168 Set_Suppress_Style_Checks
23169 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
23170 exit when No
(Homonym
(E
));
23177 -- One argument form
23180 Check_Arg_Count
(1);
23182 if Nkind
(A
) = N_String_Literal
then
23186 Slen
: constant Natural := Natural (String_Length
(S
));
23187 Options
: String (1 .. Slen
);
23193 C
:= Get_String_Char
(S
, Pos
(J
));
23194 exit when not In_Character_Range
(C
);
23195 Options
(J
) := Get_Character
(C
);
23197 -- If at end of string, set options. As per discussion
23198 -- above, no need to check for errors, since we issued
23199 -- them in the parser.
23202 if not Ignore_Style_Checks_Pragmas
then
23203 Set_Style_Check_Options
(Options
);
23213 elsif Nkind
(A
) = N_Identifier
then
23214 if Chars
(A
) = Name_All_Checks
then
23215 if not Ignore_Style_Checks_Pragmas
then
23217 Set_GNAT_Style_Check_Options
;
23219 Set_Default_Style_Check_Options
;
23223 elsif Chars
(A
) = Name_On
then
23224 if not Ignore_Style_Checks_Pragmas
then
23225 Style_Check
:= True;
23228 elsif Chars
(A
) = Name_Off
then
23229 if not Ignore_Style_Checks_Pragmas
then
23230 Style_Check
:= False;
23241 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23243 when Pragma_Subtitle
=>
23245 Check_Arg_Count
(1);
23246 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
23247 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23254 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23256 when Pragma_Suppress
=>
23257 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
23263 -- pragma Suppress_All;
23265 -- The only check made here is that the pragma has no arguments.
23266 -- There are no placement rules, and the processing required (setting
23267 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23268 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23269 -- then creates and inserts a pragma Suppress (All_Checks).
23271 when Pragma_Suppress_All
=>
23273 Check_Arg_Count
(0);
23275 -------------------------
23276 -- Suppress_Debug_Info --
23277 -------------------------
23279 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23281 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
23282 Nam_Id
: Entity_Id
;
23286 Check_Arg_Count
(1);
23287 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23288 Check_Arg_Is_Local_Name
(Arg1
);
23290 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
23292 -- A pragma that applies to a Ghost entity becomes Ghost for the
23293 -- purposes of legality checks and removal of ignored Ghost code.
23295 Mark_Ghost_Pragma
(N
, Nam_Id
);
23296 Set_Debug_Info_Off
(Nam_Id
);
23297 end Suppress_Debug_Info
;
23299 ----------------------------------
23300 -- Suppress_Exception_Locations --
23301 ----------------------------------
23303 -- pragma Suppress_Exception_Locations;
23305 when Pragma_Suppress_Exception_Locations
=>
23307 Check_Arg_Count
(0);
23308 Check_Valid_Configuration_Pragma
;
23309 Exception_Locations_Suppressed
:= True;
23311 -----------------------------
23312 -- Suppress_Initialization --
23313 -----------------------------
23315 -- pragma Suppress_Initialization ([Entity =>] type_Name);
23317 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
23323 Check_Arg_Count
(1);
23324 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23325 Check_Arg_Is_Local_Name
(Arg1
);
23327 E_Id
:= Get_Pragma_Arg
(Arg1
);
23329 if Etype
(E_Id
) = Any_Type
then
23333 E
:= Entity
(E_Id
);
23335 -- A pragma that applies to a Ghost entity becomes Ghost for the
23336 -- purposes of legality checks and removal of ignored Ghost code.
23338 Mark_Ghost_Pragma
(N
, E
);
23340 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
23342 ("pragma% requires variable, type or subtype", Arg1
);
23345 if Rep_Item_Too_Early
(E
, N
)
23347 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
23352 -- For incomplete/private type, set flag on full view
23354 if Is_Incomplete_Or_Private_Type
(E
) then
23355 if No
(Full_View
(Base_Type
(E
))) then
23357 ("argument of pragma% cannot be an incomplete type", Arg1
);
23359 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
23362 -- For first subtype, set flag on base type
23364 elsif Is_First_Subtype
(E
) then
23365 Set_Suppress_Initialization
(Base_Type
(E
));
23367 -- For other than first subtype, set flag on subtype or variable
23370 Set_Suppress_Initialization
(E
);
23378 -- pragma System_Name (DIRECT_NAME);
23380 -- Syntax check: one argument, which must be the identifier GNAT or
23381 -- the identifier GCC, no other identifiers are acceptable.
23383 when Pragma_System_Name
=>
23385 Check_No_Identifiers
;
23386 Check_Arg_Count
(1);
23387 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
23389 -----------------------------
23390 -- Task_Dispatching_Policy --
23391 -----------------------------
23393 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
23395 when Pragma_Task_Dispatching_Policy
=> declare
23399 Check_Ada_83_Warning
;
23400 Check_Arg_Count
(1);
23401 Check_No_Identifiers
;
23402 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
23403 Check_Valid_Configuration_Pragma
;
23404 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23405 DP
:= Fold_Upper
(Name_Buffer
(1));
23407 if Task_Dispatching_Policy
/= ' '
23408 and then Task_Dispatching_Policy
/= DP
23410 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
23412 ("task dispatching policy incompatible with policy#");
23414 -- Set new policy, but always preserve System_Location since we
23415 -- like the error message with the run time name.
23418 Task_Dispatching_Policy
:= DP
;
23420 if Task_Dispatching_Policy_Sloc
/= System_Location
then
23421 Task_Dispatching_Policy_Sloc
:= Loc
;
23430 -- pragma Task_Info (EXPRESSION);
23432 when Pragma_Task_Info
=> Task_Info
: declare
23433 P
: constant Node_Id
:= Parent
(N
);
23439 if Warn_On_Obsolescent_Feature
then
23441 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
23442 & "instead?j?", N
);
23445 if Nkind
(P
) /= N_Task_Definition
then
23446 Error_Pragma
("pragma% must appear in task definition");
23449 Check_No_Identifiers
;
23450 Check_Arg_Count
(1);
23452 Analyze_And_Resolve
23453 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
23455 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
23459 Ent
:= Defining_Identifier
(Parent
(P
));
23461 -- Check duplicate pragma before we chain the pragma in the Rep
23462 -- Item chain of Ent.
23465 (Ent
, Name_Task_Info
, Check_Parents
=> False)
23467 Error_Pragma
("duplicate pragma% not allowed");
23470 Record_Rep_Item
(Ent
, N
);
23477 -- pragma Task_Name (string_EXPRESSION);
23479 when Pragma_Task_Name
=> Task_Name
: declare
23480 P
: constant Node_Id
:= Parent
(N
);
23485 Check_No_Identifiers
;
23486 Check_Arg_Count
(1);
23488 Arg
:= Get_Pragma_Arg
(Arg1
);
23490 -- The expression is used in the call to Create_Task, and must be
23491 -- expanded there, not in the context of the current spec. It must
23492 -- however be analyzed to capture global references, in case it
23493 -- appears in a generic context.
23495 Preanalyze_And_Resolve
(Arg
, Standard_String
);
23497 if Nkind
(P
) /= N_Task_Definition
then
23501 Ent
:= Defining_Identifier
(Parent
(P
));
23503 -- Check duplicate pragma before we chain the pragma in the Rep
23504 -- Item chain of Ent.
23507 (Ent
, Name_Task_Name
, Check_Parents
=> False)
23509 Error_Pragma
("duplicate pragma% not allowed");
23512 Record_Rep_Item
(Ent
, N
);
23519 -- pragma Task_Storage (
23520 -- [Task_Type =>] LOCAL_NAME,
23521 -- [Top_Guard =>] static_integer_EXPRESSION);
23523 when Pragma_Task_Storage
=> Task_Storage
: declare
23524 Args
: Args_List
(1 .. 2);
23525 Names
: constant Name_List
(1 .. 2) := (
23529 Task_Type
: Node_Id
renames Args
(1);
23530 Top_Guard
: Node_Id
renames Args
(2);
23536 Gather_Associations
(Names
, Args
);
23538 if No
(Task_Type
) then
23540 ("missing task_type argument for pragma%");
23543 Check_Arg_Is_Local_Name
(Task_Type
);
23545 Ent
:= Entity
(Task_Type
);
23547 if not Is_Task_Type
(Ent
) then
23549 ("argument for pragma% must be task type", Task_Type
);
23552 if No
(Top_Guard
) then
23554 ("pragma% takes two arguments", Task_Type
);
23556 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
23559 Check_First_Subtype
(Task_Type
);
23561 if Rep_Item_Too_Late
(Ent
, N
) then
23570 -- pragma Test_Case
23571 -- ([Name =>] Static_String_EXPRESSION
23572 -- ,[Mode =>] MODE_TYPE
23573 -- [, Requires => Boolean_EXPRESSION]
23574 -- [, Ensures => Boolean_EXPRESSION]);
23576 -- MODE_TYPE ::= Nominal | Robustness
23578 -- Characteristics:
23580 -- * Analysis - The annotation undergoes initial checks to verify
23581 -- the legal placement and context. Secondary checks preanalyze the
23584 -- Analyze_Test_Case_In_Decl_Part
23586 -- * Expansion - None.
23588 -- * Template - The annotation utilizes the generic template of the
23589 -- related subprogram when it is:
23591 -- aspect on subprogram declaration
23593 -- The annotation must prepare its own template when it is:
23595 -- pragma on subprogram declaration
23597 -- * Globals - Capture of global references must occur after full
23600 -- * Instance - The annotation is instantiated automatically when
23601 -- the related generic subprogram is instantiated except for the
23602 -- "pragma on subprogram declaration" case. In that scenario the
23603 -- annotation must instantiate itself.
23605 when Pragma_Test_Case
=> Test_Case
: declare
23606 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
23607 -- Ensure that the contract of subprogram Subp_Id does not contain
23608 -- another Test_Case pragma with the same Name as the current one.
23610 -------------------------
23611 -- Check_Distinct_Name --
23612 -------------------------
23614 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
23615 Items
: constant Node_Id
:= Contract
(Subp_Id
);
23616 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
23620 -- Inspect all Test_Case pragma of the related subprogram
23621 -- looking for one with a duplicate "Name" argument.
23623 if Present
(Items
) then
23624 Prag
:= Contract_Test_Cases
(Items
);
23625 while Present
(Prag
) loop
23626 if Pragma_Name
(Prag
) = Name_Test_Case
23628 and then String_Equal
23629 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
23631 Error_Msg_Sloc
:= Sloc
(Prag
);
23632 Error_Pragma
("name for pragma % is already used #");
23635 Prag
:= Next_Pragma
(Prag
);
23638 end Check_Distinct_Name
;
23642 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
23645 Subp_Decl
: Node_Id
;
23646 Subp_Id
: Entity_Id
;
23648 -- Start of processing for Test_Case
23652 Check_At_Least_N_Arguments
(2);
23653 Check_At_Most_N_Arguments
(4);
23655 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
23659 Check_Optional_Identifier
(Arg1
, Name_Name
);
23660 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23664 Check_Optional_Identifier
(Arg2
, Name_Mode
);
23665 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
23667 -- Arguments "Requires" and "Ensures"
23669 if Present
(Arg3
) then
23670 if Present
(Arg4
) then
23671 Check_Identifier
(Arg3
, Name_Requires
);
23672 Check_Identifier
(Arg4
, Name_Ensures
);
23674 Check_Identifier_Is_One_Of
23675 (Arg3
, Name_Requires
, Name_Ensures
);
23679 -- Pragma Test_Case must be associated with a subprogram declared
23680 -- in a library-level package. First determine whether the current
23681 -- compilation unit is a legal context.
23683 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
23684 N_Generic_Package_Declaration
)
23688 -- Otherwise the placement is illegal
23692 ("pragma % must be specified within a package declaration");
23696 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
23698 -- Find the enclosing context
23700 Context
:= Parent
(Subp_Decl
);
23702 if Present
(Context
) then
23703 Context
:= Parent
(Context
);
23706 -- Verify the placement of the pragma
23708 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23710 ("pragma % cannot be applied to abstract subprogram");
23713 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
23714 Error_Pragma
("pragma % cannot be applied to entry");
23717 -- The context is a [generic] subprogram declared at the top level
23718 -- of the [generic] package unit.
23720 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
23721 N_Subprogram_Declaration
)
23722 and then Present
(Context
)
23723 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
23724 N_Package_Declaration
)
23728 -- Otherwise the placement is illegal
23732 ("pragma % must be applied to a library-level subprogram "
23737 Subp_Id
:= Defining_Entity
(Subp_Decl
);
23739 -- A pragma that applies to a Ghost entity becomes Ghost for the
23740 -- purposes of legality checks and removal of ignored Ghost code.
23742 Mark_Ghost_Pragma
(N
, Subp_Id
);
23744 -- Chain the pragma on the contract for further processing by
23745 -- Analyze_Test_Case_In_Decl_Part.
23747 Add_Contract_Item
(N
, Subp_Id
);
23749 -- Preanalyze the original aspect argument "Name" for ASIS or for
23750 -- a generic subprogram to properly capture global references.
23752 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
23753 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
23755 if Present
(Asp_Arg
) then
23757 -- The argument appears with an identifier in association
23760 if Nkind
(Asp_Arg
) = N_Component_Association
then
23761 Asp_Arg
:= Expression
(Asp_Arg
);
23764 Check_Expr_Is_OK_Static_Expression
23765 (Asp_Arg
, Standard_String
);
23769 -- Ensure that the all Test_Case pragmas of the related subprogram
23770 -- have distinct names.
23772 Check_Distinct_Name
(Subp_Id
);
23774 -- Fully analyze the pragma when it appears inside an entry
23775 -- or subprogram body because it cannot benefit from forward
23778 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
23780 N_Subprogram_Body_Stub
)
23782 -- The legality checks of pragma Test_Case are affected by the
23783 -- SPARK mode in effect and the volatility of the context.
23784 -- Analyze all pragmas in a specific order.
23786 Analyze_If_Present
(Pragma_SPARK_Mode
);
23787 Analyze_If_Present
(Pragma_Volatile_Function
);
23788 Analyze_Test_Case_In_Decl_Part
(N
);
23792 --------------------------
23793 -- Thread_Local_Storage --
23794 --------------------------
23796 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
23798 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
23804 Check_Arg_Count
(1);
23805 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23806 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23808 Id
:= Get_Pragma_Arg
(Arg1
);
23811 if not Is_Entity_Name
(Id
)
23812 or else Ekind
(Entity
(Id
)) /= E_Variable
23814 Error_Pragma_Arg
("local variable name required", Arg1
);
23819 -- A pragma that applies to a Ghost entity becomes Ghost for the
23820 -- purposes of legality checks and removal of ignored Ghost code.
23822 Mark_Ghost_Pragma
(N
, E
);
23824 if Rep_Item_Too_Early
(E
, N
)
23826 Rep_Item_Too_Late
(E
, N
)
23831 Set_Has_Pragma_Thread_Local_Storage
(E
);
23832 Set_Has_Gigi_Rep_Item
(E
);
23833 end Thread_Local_Storage
;
23839 -- pragma Time_Slice (static_duration_EXPRESSION);
23841 when Pragma_Time_Slice
=> Time_Slice
: declare
23847 Check_Arg_Count
(1);
23848 Check_No_Identifiers
;
23849 Check_In_Main_Program
;
23850 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
23852 if not Error_Posted
(Arg1
) then
23854 while Present
(Nod
) loop
23855 if Nkind
(Nod
) = N_Pragma
23856 and then Pragma_Name
(Nod
) = Name_Time_Slice
23858 Error_Msg_Name_1
:= Pname
;
23859 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
23866 -- Process only if in main unit
23868 if Get_Source_Unit
(Loc
) = Main_Unit
then
23869 Opt
.Time_Slice_Set
:= True;
23870 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
23872 if Val
<= Ureal_0
then
23873 Opt
.Time_Slice_Value
:= 0;
23875 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
23876 Opt
.Time_Slice_Value
:= 1_000_000_000
;
23879 Opt
.Time_Slice_Value
:=
23880 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
23889 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
23891 -- TITLING_OPTION ::=
23892 -- [Title =>] STRING_LITERAL
23893 -- | [Subtitle =>] STRING_LITERAL
23895 when Pragma_Title
=> Title
: declare
23896 Args
: Args_List
(1 .. 2);
23897 Names
: constant Name_List
(1 .. 2) := (
23903 Gather_Associations
(Names
, Args
);
23906 for J
in 1 .. 2 loop
23907 if Present
(Args
(J
)) then
23908 Check_Arg_Is_OK_Static_Expression
23909 (Args
(J
), Standard_String
);
23914 ----------------------------
23915 -- Type_Invariant[_Class] --
23916 ----------------------------
23918 -- pragma Type_Invariant[_Class]
23919 -- ([Entity =>] type_LOCAL_NAME,
23920 -- [Check =>] EXPRESSION);
23922 when Pragma_Type_Invariant
23923 | Pragma_Type_Invariant_Class
23925 Type_Invariant
: declare
23926 I_Pragma
: Node_Id
;
23929 Check_Arg_Count
(2);
23931 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23932 -- setting Class_Present for the Type_Invariant_Class case.
23934 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
23935 I_Pragma
:= New_Copy
(N
);
23936 Set_Pragma_Identifier
23937 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
23938 Rewrite
(N
, I_Pragma
);
23939 Set_Analyzed
(N
, False);
23941 end Type_Invariant
;
23943 ---------------------
23944 -- Unchecked_Union --
23945 ---------------------
23947 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23949 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
23950 Assoc
: constant Node_Id
:= Arg1
;
23951 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
23961 Check_No_Identifiers
;
23962 Check_Arg_Count
(1);
23963 Check_Arg_Is_Local_Name
(Arg1
);
23965 Find_Type
(Type_Id
);
23967 Typ
:= Entity
(Type_Id
);
23969 -- A pragma that applies to a Ghost entity becomes Ghost for the
23970 -- purposes of legality checks and removal of ignored Ghost code.
23972 Mark_Ghost_Pragma
(N
, Typ
);
23975 or else Rep_Item_Too_Early
(Typ
, N
)
23979 Typ
:= Underlying_Type
(Typ
);
23982 if Rep_Item_Too_Late
(Typ
, N
) then
23986 Check_First_Subtype
(Arg1
);
23988 -- Note remaining cases are references to a type in the current
23989 -- declarative part. If we find an error, we post the error on
23990 -- the relevant type declaration at an appropriate point.
23992 if not Is_Record_Type
(Typ
) then
23993 Error_Msg_N
("unchecked union must be record type", Typ
);
23996 elsif Is_Tagged_Type
(Typ
) then
23997 Error_Msg_N
("unchecked union must not be tagged", Typ
);
24000 elsif not Has_Discriminants
(Typ
) then
24002 ("unchecked union must have one discriminant", Typ
);
24005 -- Note: in previous versions of GNAT we used to check for limited
24006 -- types and give an error, but in fact the standard does allow
24007 -- Unchecked_Union on limited types, so this check was removed.
24009 -- Similarly, GNAT used to require that all discriminants have
24010 -- default values, but this is not mandated by the RM.
24012 -- Proceed with basic error checks completed
24015 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
24016 Clist
:= Component_List
(Tdef
);
24018 -- Check presence of component list and variant part
24020 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
24022 ("unchecked union must have variant part", Tdef
);
24026 -- Check components
24028 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
24029 while Present
(Comp
) loop
24030 Check_Component
(Comp
, Typ
);
24031 Next_Non_Pragma
(Comp
);
24034 -- Check variant part
24036 Vpart
:= Variant_Part
(Clist
);
24038 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
24039 while Present
(Variant
) loop
24040 Check_Variant
(Variant
, Typ
);
24041 Next_Non_Pragma
(Variant
);
24045 Set_Is_Unchecked_Union
(Typ
);
24046 Set_Convention
(Typ
, Convention_C
);
24047 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
24048 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
24049 end Unchecked_Union
;
24051 ----------------------------
24052 -- Unevaluated_Use_Of_Old --
24053 ----------------------------
24055 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24057 when Pragma_Unevaluated_Use_Of_Old
=>
24059 Check_Arg_Count
(1);
24060 Check_No_Identifiers
;
24061 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
24063 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24064 -- a declarative part or a package spec.
24066 if not Is_Configuration_Pragma
then
24067 Check_Is_In_Decl_Part_Or_Package_Spec
;
24070 -- Store proper setting of Uneval_Old
24072 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24073 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
24075 ------------------------
24076 -- Unimplemented_Unit --
24077 ------------------------
24079 -- pragma Unimplemented_Unit;
24081 -- Note: this only gives an error if we are generating code, or if
24082 -- we are in a generic library unit (where the pragma appears in the
24083 -- body, not in the spec).
24085 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
24086 Cunitent
: constant Entity_Id
:=
24087 Cunit_Entity
(Get_Source_Unit
(Loc
));
24088 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
24092 Check_Arg_Count
(0);
24094 if Operating_Mode
= Generate_Code
24095 or else Ent_Kind
= E_Generic_Function
24096 or else Ent_Kind
= E_Generic_Procedure
24097 or else Ent_Kind
= E_Generic_Package
24099 Get_Name_String
(Chars
(Cunitent
));
24100 Set_Casing
(Mixed_Case
);
24101 Write_Str
(Name_Buffer
(1 .. Name_Len
));
24102 Write_Str
(" is not supported in this configuration");
24104 raise Unrecoverable_Error
;
24106 end Unimplemented_Unit
;
24108 ------------------------
24109 -- Universal_Aliasing --
24110 ------------------------
24112 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24114 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
24120 Check_Arg_Count
(1);
24121 Check_Optional_Identifier
(Arg2
, Name_Entity
);
24122 Check_Arg_Is_Local_Name
(Arg1
);
24123 E_Id
:= Get_Pragma_Arg
(Arg1
);
24125 if Etype
(E_Id
) = Any_Type
then
24129 E
:= Entity
(E_Id
);
24131 if not Is_Type
(E
) then
24132 Error_Pragma_Arg
("pragma% requires type", Arg1
);
24135 -- A pragma that applies to a Ghost entity becomes Ghost for the
24136 -- purposes of legality checks and removal of ignored Ghost code.
24138 Mark_Ghost_Pragma
(N
, E
);
24139 Set_Universal_Aliasing
(Base_Type
(E
));
24140 Record_Rep_Item
(E
, N
);
24141 end Universal_Alias
;
24143 --------------------
24144 -- Universal_Data --
24145 --------------------
24147 -- pragma Universal_Data [(library_unit_NAME)];
24149 when Pragma_Universal_Data
=>
24151 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
24157 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24159 when Pragma_Unmodified
=>
24160 Analyze_Unmodified_Or_Unused
;
24166 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24168 -- or when used in a context clause:
24170 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24172 when Pragma_Unreferenced
=>
24173 Analyze_Unreferenced_Or_Unused
;
24175 --------------------------
24176 -- Unreferenced_Objects --
24177 --------------------------
24179 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24181 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
24183 Arg_Expr
: Node_Id
;
24184 Arg_Id
: Entity_Id
;
24186 Ghost_Error_Posted
: Boolean := False;
24187 -- Flag set when an error concerning the illegal mix of Ghost and
24188 -- non-Ghost types is emitted.
24190 Ghost_Id
: Entity_Id
:= Empty
;
24191 -- The entity of the first Ghost type encountered while processing
24192 -- the arguments of the pragma.
24196 Check_At_Least_N_Arguments
(1);
24199 while Present
(Arg
) loop
24200 Check_No_Identifier
(Arg
);
24201 Check_Arg_Is_Local_Name
(Arg
);
24202 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
24204 if Is_Entity_Name
(Arg_Expr
) then
24205 Arg_Id
:= Entity
(Arg_Expr
);
24207 if Is_Type
(Arg_Id
) then
24208 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
24210 -- A pragma that applies to a Ghost entity becomes Ghost
24211 -- for the purposes of legality checks and removal of
24212 -- ignored Ghost code.
24214 Mark_Ghost_Pragma
(N
, Arg_Id
);
24216 -- Capture the entity of the first Ghost type being
24217 -- processed for error detection purposes.
24219 if Is_Ghost_Entity
(Arg_Id
) then
24220 if No
(Ghost_Id
) then
24221 Ghost_Id
:= Arg_Id
;
24224 -- Otherwise the type is non-Ghost. It is illegal to mix
24225 -- references to Ghost and non-Ghost entities
24228 elsif Present
(Ghost_Id
)
24229 and then not Ghost_Error_Posted
24231 Ghost_Error_Posted
:= True;
24233 Error_Msg_Name_1
:= Pname
;
24235 ("pragma % cannot mention ghost and non-ghost types",
24238 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
24239 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
24241 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
24242 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
24246 ("argument for pragma% must be type or subtype", Arg
);
24250 ("argument for pragma% must be type or subtype", Arg
);
24255 end Unreferenced_Objects
;
24257 ------------------------------
24258 -- Unreserve_All_Interrupts --
24259 ------------------------------
24261 -- pragma Unreserve_All_Interrupts;
24263 when Pragma_Unreserve_All_Interrupts
=>
24265 Check_Arg_Count
(0);
24267 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
24268 Unreserve_All_Interrupts
:= True;
24275 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24277 when Pragma_Unsuppress
=>
24279 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
24285 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24287 when Pragma_Unused
=>
24288 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
24289 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
24291 -------------------
24292 -- Use_VADS_Size --
24293 -------------------
24295 -- pragma Use_VADS_Size;
24297 when Pragma_Use_VADS_Size
=>
24299 Check_Arg_Count
(0);
24300 Check_Valid_Configuration_Pragma
;
24301 Use_VADS_Size
:= True;
24303 ---------------------
24304 -- Validity_Checks --
24305 ---------------------
24307 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24309 when Pragma_Validity_Checks
=> Validity_Checks
: declare
24310 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
24316 Check_Arg_Count
(1);
24317 Check_No_Identifiers
;
24319 -- Pragma always active unless in CodePeer or GNATprove modes,
24320 -- which use a fixed configuration of validity checks.
24322 if not (CodePeer_Mode
or GNATprove_Mode
) then
24323 if Nkind
(A
) = N_String_Literal
then
24327 Slen
: constant Natural := Natural (String_Length
(S
));
24328 Options
: String (1 .. Slen
);
24332 -- Couldn't we use a for loop here over Options'Range???
24336 C
:= Get_String_Char
(S
, Pos
(J
));
24338 -- This is a weird test, it skips setting validity
24339 -- checks entirely if any element of S is out of
24340 -- range of Character, what is that about ???
24342 exit when not In_Character_Range
(C
);
24343 Options
(J
) := Get_Character
(C
);
24346 Set_Validity_Check_Options
(Options
);
24354 elsif Nkind
(A
) = N_Identifier
then
24355 if Chars
(A
) = Name_All_Checks
then
24356 Set_Validity_Check_Options
("a");
24357 elsif Chars
(A
) = Name_On
then
24358 Validity_Checks_On
:= True;
24359 elsif Chars
(A
) = Name_Off
then
24360 Validity_Checks_On
:= False;
24364 end Validity_Checks
;
24370 -- pragma Volatile (LOCAL_NAME);
24372 when Pragma_Volatile
=>
24373 Process_Atomic_Independent_Shared_Volatile
;
24375 -------------------------
24376 -- Volatile_Components --
24377 -------------------------
24379 -- pragma Volatile_Components (array_LOCAL_NAME);
24381 -- Volatile is handled by the same circuit as Atomic_Components
24383 --------------------------
24384 -- Volatile_Full_Access --
24385 --------------------------
24387 -- pragma Volatile_Full_Access (LOCAL_NAME);
24389 when Pragma_Volatile_Full_Access
=>
24391 Process_Atomic_Independent_Shared_Volatile
;
24393 -----------------------
24394 -- Volatile_Function --
24395 -----------------------
24397 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
24399 when Pragma_Volatile_Function
=> Volatile_Function
: declare
24400 Over_Id
: Entity_Id
;
24401 Spec_Id
: Entity_Id
;
24402 Subp_Decl
: Node_Id
;
24406 Check_No_Identifiers
;
24407 Check_At_Most_N_Arguments
(1);
24410 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
24412 -- Generic subprogram
24414 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
24417 -- Body acts as spec
24419 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
24420 and then No
(Corresponding_Spec
(Subp_Decl
))
24424 -- Body stub acts as spec
24426 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24427 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24433 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
24441 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
24443 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
24448 -- A pragma that applies to a Ghost entity becomes Ghost for the
24449 -- purposes of legality checks and removal of ignored Ghost code.
24451 Mark_Ghost_Pragma
(N
, Spec_Id
);
24453 -- Chain the pragma on the contract for completeness
24455 Add_Contract_Item
(N
, Spec_Id
);
24457 -- The legality checks of pragma Volatile_Function are affected by
24458 -- the SPARK mode in effect. Analyze all pragmas in a specific
24461 Analyze_If_Present
(Pragma_SPARK_Mode
);
24463 -- A volatile function cannot override a non-volatile function
24464 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24465 -- in New_Overloaded_Entity, however at that point the pragma has
24466 -- not been processed yet.
24468 Over_Id
:= Overridden_Operation
(Spec_Id
);
24470 if Present
(Over_Id
)
24471 and then not Is_Volatile_Function
(Over_Id
)
24474 ("incompatible volatile function values in effect", Spec_Id
);
24476 Error_Msg_Sloc
:= Sloc
(Over_Id
);
24478 ("\& declared # with Volatile_Function value False",
24481 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
24483 ("\overridden # with Volatile_Function value True",
24487 -- Analyze the Boolean expression (if any)
24489 if Present
(Arg1
) then
24490 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
24492 end Volatile_Function
;
24494 ----------------------
24495 -- Warning_As_Error --
24496 ----------------------
24498 -- pragma Warning_As_Error (static_string_EXPRESSION);
24500 when Pragma_Warning_As_Error
=>
24502 Check_Arg_Count
(1);
24503 Check_No_Identifiers
;
24504 Check_Valid_Configuration_Pragma
;
24506 if not Is_Static_String_Expression
(Arg1
) then
24508 ("argument of pragma% must be static string expression",
24511 -- OK static string expression
24514 Acquire_Warning_Match_String
(Arg1
);
24515 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
24516 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
24517 new String'(Name_Buffer (1 .. Name_Len));
24524 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24526 -- DETAILS ::= On | Off
24527 -- DETAILS ::= On | Off, local_NAME
24528 -- DETAILS ::= static_string_EXPRESSION
24529 -- DETAILS ::= On | Off, static_string_EXPRESSION
24531 -- TOOL_NAME ::= GNAT | GNATProve
24533 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24535 -- Note: If the first argument matches an allowed tool name, it is
24536 -- always considered to be a tool name, even if there is a string
24537 -- variable of that name.
24539 -- Note if the second argument of DETAILS is a local_NAME then the
24540 -- second form is always understood. If the intention is to use
24541 -- the fourth form, then you can write NAME & "" to force the
24542 -- intepretation as a static_string_EXPRESSION.
24544 when Pragma_Warnings => Warnings : declare
24545 Reason : String_Id;
24549 Check_At_Least_N_Arguments (1);
24551 -- See if last argument is labeled Reason. If so, make sure we
24552 -- have a string literal or a concatenation of string literals,
24553 -- and acquire the REASON string. Then remove the REASON argument
24554 -- by decreasing Num_Args by one; Remaining processing looks only
24555 -- at first Num_Args arguments).
24558 Last_Arg : constant Node_Id :=
24559 Last (Pragma_Argument_Associations (N));
24562 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24563 and then Chars (Last_Arg) = Name_Reason
24566 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24567 Reason := End_String;
24568 Arg_Count := Arg_Count - 1;
24570 -- Not allowed in compiler units (bootstrap issues)
24572 Check_Compiler_Unit ("Reason for pragma Warnings", N);
24574 -- No REASON string, set null string as reason
24577 Reason := Null_String_Id;
24581 -- Now proceed with REASON taken care of and eliminated
24583 Check_No_Identifiers;
24585 -- If debug flag -gnatd.i is set, pragma is ignored
24587 if Debug_Flag_Dot_I then
24591 -- Process various forms of the pragma
24594 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
24595 Shifted_Args : List_Id;
24598 -- See if first argument is a tool name, currently either
24599 -- GNAT or GNATprove. If so, either ignore the pragma if the
24600 -- tool used does not match, or continue as if no tool name
24601 -- was given otherwise, by shifting the arguments.
24603 if Nkind (Argx) = N_Identifier
24604 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
24606 if Chars (Argx) = Name_Gnat then
24607 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
24608 Rewrite (N, Make_Null_Statement (Loc));
24613 elsif Chars (Argx) = Name_Gnatprove then
24614 if not GNATprove_Mode then
24615 Rewrite (N, Make_Null_Statement (Loc));
24621 raise Program_Error;
24624 -- At this point, the pragma Warnings applies to the tool,
24625 -- so continue with shifted arguments.
24627 Arg_Count := Arg_Count - 1;
24629 if Arg_Count = 1 then
24630 Shifted_Args := New_List (New_Copy (Arg2));
24631 elsif Arg_Count = 2 then
24632 Shifted_Args := New_List (New_Copy (Arg2),
24634 elsif Arg_Count = 3 then
24635 Shifted_Args := New_List (New_Copy (Arg2),
24639 raise Program_Error;
24644 Chars => Name_Warnings,
24645 Pragma_Argument_Associations => Shifted_Args));
24650 -- One argument case
24652 if Arg_Count = 1 then
24654 -- On/Off one argument case was processed by parser
24656 if Nkind (Argx) = N_Identifier
24657 and then Nam_In (Chars (Argx), Name_On, Name_Off)
24661 -- One argument case must be ON/OFF or static string expr
24663 elsif not Is_Static_String_Expression (Arg1) then
24665 ("argument of pragma% must be On/Off or static string "
24666 & "expression", Arg1);
24668 -- One argument string expression case
24672 Lit : constant Node_Id := Expr_Value_S (Argx);
24673 Str : constant String_Id := Strval (Lit);
24674 Len : constant Nat := String_Length (Str);
24682 while J <= Len loop
24683 C := Get_String_Char (Str, J);
24684 OK := In_Character_Range (C);
24687 Chr := Get_Character (C);
24689 -- Dash case: only -Wxxx is accepted
24696 C := Get_String_Char (Str, J);
24697 Chr := Get_Character (C);
24698 exit when Chr = 'W
';
24703 elsif J < Len and then Chr = '.' then
24705 C := Get_String_Char (Str, J);
24706 Chr := Get_Character (C);
24708 if not Set_Dot_Warning_Switch (Chr) then
24710 ("invalid warning switch character "
24711 & '.' & Chr, Arg1);
24717 OK := Set_Warning_Switch (Chr);
24722 ("invalid warning switch character " & Chr,
24728 ("invalid wide character in warning switch ",
24737 -- Two or more arguments (must be two)
24740 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24741 Check_Arg_Count (2);
24749 E_Id := Get_Pragma_Arg (Arg2);
24752 -- In the expansion of an inlined body, a reference to
24753 -- the formal may be wrapped in a conversion if the
24754 -- actual is a conversion. Retrieve the real entity name.
24756 if (In_Instance_Body or In_Inlined_Body)
24757 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
24759 E_Id := Expression (E_Id);
24762 -- Entity name case
24764 if Is_Entity_Name (E_Id) then
24765 E := Entity (E_Id);
24772 (E, (Chars (Get_Pragma_Arg (Arg1)) =
24775 -- Suppress elaboration warnings if the entity
24776 -- denotes an elaboration target.
24778 if Is_Elaboration_Target (E) then
24779 Set_Is_Elaboration_Warnings_OK_Id (E, False);
24782 -- For OFF case, make entry in warnings off
24783 -- pragma table for later processing. But we do
24784 -- not do that within an instance, since these
24785 -- warnings are about what is needed in the
24786 -- template, not an instance of it.
24788 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
24789 and then Warn_On_Warnings_Off
24790 and then not In_Instance
24792 Warnings_Off_Pragmas.Append ((N, E, Reason));
24795 if Is_Enumeration_Type (E) then
24799 Lit := First_Literal (E);
24800 while Present (Lit) loop
24801 Set_Warnings_Off (Lit);
24802 Next_Literal (Lit);
24807 exit when No (Homonym (E));
24812 -- Error if not entity or static string expression case
24814 elsif not Is_Static_String_Expression (Arg2) then
24816 ("second argument of pragma% must be entity name "
24817 & "or static string expression", Arg2);
24819 -- Static string expression case
24822 Acquire_Warning_Match_String (Arg2);
24824 -- Note on configuration pragma case: If this is a
24825 -- configuration pragma, then for an OFF pragma, we
24826 -- just set Config True in the call, which is all
24827 -- that needs to be done. For the case of ON, this
24828 -- is normally an error, unless it is canceling the
24829 -- effect of a previous OFF pragma in the same file.
24830 -- In any other case, an error will be signalled (ON
24831 -- with no matching OFF).
24833 -- Note: We set Used if we are inside a generic to
24834 -- disable the test that the non-config case actually
24835 -- cancels a warning. That's because we can't be sure
24836 -- there isn't an instantiation in some other unit
24837 -- where a warning is suppressed.
24839 -- We could do a little better here by checking if the
24840 -- generic unit we are inside is public, but for now
24841 -- we don't bother with that refinement.
24843 if Chars (Argx) = Name_Off then
24844 Set_Specific_Warning_Off
24845 (Loc, Name_Buffer (1 .. Name_Len), Reason,
24846 Config => Is_Configuration_Pragma,
24847 Used => Inside_A_Generic or else In_Instance);
24849 elsif Chars (Argx) = Name_On then
24850 Set_Specific_Warning_On
24851 (Loc, Name_Buffer (1 .. Name_Len), Err);
24855 ("??pragma Warnings On with no matching "
24856 & "Warnings Off", Loc);
24865 -------------------
24866 -- Weak_External --
24867 -------------------
24869 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
24871 when Pragma_Weak_External => Weak_External : declare
24876 Check_Arg_Count (1);
24877 Check_Optional_Identifier (Arg1, Name_Entity);
24878 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24879 Ent := Entity (Get_Pragma_Arg (Arg1));
24881 if Rep_Item_Too_Early (Ent, N) then
24884 Ent := Underlying_Type (Ent);
24887 -- The only processing required is to link this item on to the
24888 -- list of rep items for the given entity. This is accomplished
24889 -- by the call to Rep_Item_Too_Late (when no error is detected
24890 -- and False is returned).
24892 if Rep_Item_Too_Late (Ent, N) then
24895 Set_Has_Gigi_Rep_Item (Ent);
24899 -----------------------------
24900 -- Wide_Character_Encoding --
24901 -----------------------------
24903 -- pragma Wide_Character_Encoding (IDENTIFIER);
24905 when Pragma_Wide_Character_Encoding =>
24908 -- Nothing to do, handled in parser. Note that we do not enforce
24909 -- configuration pragma placement, this pragma can appear at any
24910 -- place in the source, allowing mixed encodings within a single
24915 --------------------
24916 -- Unknown_Pragma --
24917 --------------------
24919 -- Should be impossible, since the case of an unknown pragma is
24920 -- separately processed before the case statement is entered.
24922 when Unknown_Pragma =>
24923 raise Program_Error;
24926 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24927 -- until AI is formally approved.
24929 -- Check_Order_Dependence;
24932 when Pragma_Exit => null;
24933 end Analyze_Pragma;
24935 ---------------------------------------------
24936 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24937 ---------------------------------------------
24939 -- WARNING: This routine manages Ghost regions. Return statements must be
24940 -- replaced by gotos which jump to the end of the routine and restore the
24943 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24945 Freeze_Id : Entity_Id := Empty)
24947 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24948 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24950 Disp_Typ : Entity_Id;
24951 -- The dispatching type of the subprogram subject to the pre- or
24954 function Check_References (Nod : Node_Id) return Traverse_Result;
24955 -- Check that expression Nod does not mention non-primitives of the
24956 -- type, global objects of the type, or other illegalities described
24957 -- and implied by AI12-0113.
24959 ----------------------
24960 -- Check_References --
24961 ----------------------
24963 function Check_References (Nod : Node_Id) return Traverse_Result is
24965 if Nkind (Nod) = N_Function_Call
24966 and then Is_Entity_Name (Name (Nod))
24969 Func : constant Entity_Id := Entity (Name (Nod));
24973 -- An operation of the type must be a primitive
24975 if No (Find_Dispatching_Type (Func)) then
24976 Form := First_Formal (Func);
24977 while Present (Form) loop
24978 if Etype (Form) = Disp_Typ then
24980 ("operation in class-wide condition must be "
24981 & "primitive of &", Nod, Disp_Typ);
24984 Next_Formal (Form);
24987 -- A return object of the type is illegal as well
24989 if Etype (Func) = Disp_Typ
24990 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24993 ("operation in class-wide condition must be primitive "
24994 & "of &", Nod, Disp_Typ);
24997 -- Otherwise we have a call to an overridden primitive, and we
24998 -- will create a common class-wide clone for the body of
24999 -- original operation and its eventual inherited versions. If
25000 -- the original operation dispatches on result it is never
25001 -- inherited and there is no need for a clone. There is not
25002 -- need for a clone either in GNATprove mode, as cases that
25003 -- would require it are rejected (when an inherited primitive
25004 -- calls an overridden operation in a class-wide contract), and
25005 -- the clone would make proof impossible in some cases.
25007 elsif not Is_Abstract_Subprogram (Spec_Id)
25008 and then No (Class_Wide_Clone (Spec_Id))
25009 and then not Has_Controlling_Result (Spec_Id)
25010 and then not GNATprove_Mode
25012 Build_Class_Wide_Clone_Decl (Spec_Id);
25016 elsif Is_Entity_Name (Nod)
25018 (Etype (Nod) = Disp_Typ
25019 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25020 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25023 ("object in class-wide condition must be formal of type &",
25026 elsif Nkind (Nod) = N_Explicit_Dereference
25027 and then (Etype (Nod) = Disp_Typ
25028 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25029 and then (not Is_Entity_Name (Prefix (Nod))
25030 or else not Is_Formal (Entity (Prefix (Nod))))
25033 ("operation in class-wide condition must be primitive of &",
25038 end Check_References;
25040 procedure Check_Class_Wide_Condition is
25041 new Traverse_Proc (Check_References);
25045 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25047 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25048 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25049 -- Save the Ghost-related attributes to restore on exit
25052 Restore_Scope : Boolean := False;
25054 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25057 -- Do not analyze the pragma multiple times
25059 if Is_Analyzed_Pragma (N) then
25063 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25064 -- analysis of the pragma, the Ghost mode at point of declaration and
25065 -- point of analysis may not necessarily be the same. Use the mode in
25066 -- effect at the point of declaration.
25068 Set_Ghost_Mode (N);
25070 -- Ensure that the subprogram and its formals are visible when analyzing
25071 -- the expression of the pragma.
25073 if not In_Open_Scopes (Spec_Id) then
25074 Restore_Scope := True;
25075 Push_Scope (Spec_Id);
25077 if Is_Generic_Subprogram (Spec_Id) then
25078 Install_Generic_Formals (Spec_Id);
25080 Install_Formals (Spec_Id);
25084 Errors := Serious_Errors_Detected;
25085 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25087 -- Emit a clarification message when the expression contains at least
25088 -- one undefined reference, possibly due to contract freezing.
25090 if Errors /= Serious_Errors_Detected
25091 and then Present (Freeze_Id)
25092 and then Has_Undefined_Reference (Expr)
25094 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25097 if Class_Present (N) then
25099 -- Verify that a class-wide condition is legal, i.e. the operation is
25100 -- a primitive of a tagged type. Note that a generic subprogram is
25101 -- not a primitive operation.
25103 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25105 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25106 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25108 if From_Aspect_Specification (N) then
25110 ("aspect % can only be specified for a primitive operation "
25111 & "of a tagged type", Corresponding_Aspect (N));
25113 -- The pragma is a source construct
25117 ("pragma % can only be specified for a primitive operation "
25118 & "of a tagged type", N);
25121 -- Remaining semantic checks require a full tree traversal
25124 Check_Class_Wide_Condition (Expr);
25129 if Restore_Scope then
25133 -- If analysis of the condition indicates that a class-wide clone
25134 -- has been created, build and analyze its declaration.
25136 if Is_Subprogram (Spec_Id)
25137 and then Present (Class_Wide_Clone (Spec_Id))
25139 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25142 -- Currently it is not possible to inline pre/postconditions on a
25143 -- subprogram subject to pragma Inline_Always.
25145 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25146 Set_Is_Analyzed_Pragma (N);
25148 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25149 end Analyze_Pre_Post_Condition_In_Decl_Part;
25151 ------------------------------------------
25152 -- Analyze_Refined_Depends_In_Decl_Part --
25153 ------------------------------------------
25155 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25156 procedure Check_Dependency_Clause
25157 (Spec_Id : Entity_Id;
25158 Dep_Clause : Node_Id;
25159 Dep_States : Elist_Id;
25160 Refinements : List_Id;
25161 Matched_Items : in out Elist_Id);
25162 -- Try to match a single dependency clause Dep_Clause against one or
25163 -- more refinement clauses found in list Refinements. Each successful
25164 -- match eliminates at least one refinement clause from Refinements.
25165 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25166 -- denotes the entities of all abstract states which appear in pragma
25167 -- Depends. Matched_Items contains the entities of all successfully
25168 -- matched items found in pragma Depends.
25170 procedure Check_Output_States
25171 (Spec_Id : Entity_Id;
25172 Spec_Inputs : Elist_Id;
25173 Spec_Outputs : Elist_Id;
25174 Body_Inputs : Elist_Id;
25175 Body_Outputs : Elist_Id);
25176 -- Determine whether pragma Depends contains an output state with a
25177 -- visible refinement and if so, ensure that pragma Refined_Depends
25178 -- mentions all its constituents as outputs. Spec_Id is the entity of
25179 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25180 -- inputs and outputs of the subprogram spec synthesized from pragma
25181 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25182 -- of the subprogram body synthesized from pragma Refined_Depends.
25184 function Collect_States (Clauses : List_Id) return Elist_Id;
25185 -- Given a normalized list of dependencies obtained from calling
25186 -- Normalize_Clauses, return a list containing the entities of all
25187 -- states appearing in dependencies. It helps in checking refinements
25188 -- involving a state and a corresponding constituent which is not a
25189 -- direct constituent of the state.
25191 procedure Normalize_Clauses (Clauses : List_Id);
25192 -- Given a list of dependence or refinement clauses Clauses, normalize
25193 -- each clause by creating multiple dependencies with exactly one input
25196 procedure Remove_Extra_Clauses
25197 (Clauses : List_Id;
25198 Matched_Items : Elist_Id);
25199 -- Given a list of refinement clauses Clauses, remove all clauses whose
25200 -- inputs and/or outputs have been previously matched. See the body for
25201 -- all special cases. Matched_Items contains the entities of all matched
25202 -- items found in pragma Depends.
25204 procedure Report_Extra_Clauses
25205 (Spec_Id : Entity_Id;
25206 Clauses : List_Id);
25207 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25208 -- denotes the entity of the related subprogram.
25210 -----------------------------
25211 -- Check_Dependency_Clause --
25212 -----------------------------
25214 procedure Check_Dependency_Clause
25215 (Spec_Id : Entity_Id;
25216 Dep_Clause : Node_Id;
25217 Dep_States : Elist_Id;
25218 Refinements : List_Id;
25219 Matched_Items : in out Elist_Id)
25221 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25222 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25224 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25225 -- Determine whether dependency item Dep_Item has been matched in a
25226 -- previous clause.
25228 function Is_In_Out_State_Clause return Boolean;
25229 -- Determine whether dependence clause Dep_Clause denotes an abstract
25230 -- state that depends on itself (State => State).
25232 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25233 -- Determine whether item Item denotes an abstract state with visible
25234 -- null refinement.
25236 procedure Match_Items
25237 (Dep_Item : Node_Id;
25238 Ref_Item : Node_Id;
25239 Matched : out Boolean);
25240 -- Try to match dependence item Dep_Item against refinement item
25241 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25242 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25243 -- the following conformance scenarios is in effect:
25244 -- 1) Both items denote null
25245 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25246 -- 3) Both items denote attribute 'Result
25247 -- 4) Both items denote the same object
25248 -- 5) Both items denote the same formal parameter
25249 -- 6) Both items denote the same current instance of a type
25250 -- 7) Both items denote the same discriminant
25251 -- 8) Dep_Item is an abstract state with visible null refinement
25252 -- and Ref_Item denotes null.
25253 -- 9) Dep_Item is an abstract state with visible null refinement
25254 -- and Ref_Item is Empty (special case).
25255 -- 10) Dep_Item is an abstract state with full or partial visible
25256 -- non-null refinement and Ref_Item denotes one of its
25258 -- 11) Dep_Item is an abstract state without a full visible
25259 -- refinement and Ref_Item denotes the same state.
25260 -- When scenario 10 is in effect, the entity of the abstract state
25261 -- denoted by Dep_Item is added to list Refined_States.
25263 procedure Record_Item
(Item_Id
: Entity_Id
);
25264 -- Store the entity of an item denoted by Item_Id in Matched_Items
25266 ------------------------
25267 -- Is_Already_Matched --
25268 ------------------------
25270 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
25271 Item_Id
: Entity_Id
:= Empty
;
25274 -- When the dependency item denotes attribute 'Result, check for
25275 -- the entity of the related subprogram.
25277 if Is_Attribute_Result
(Dep_Item
) then
25278 Item_Id
:= Spec_Id
;
25280 elsif Is_Entity_Name
(Dep_Item
) then
25281 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25285 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
25286 end Is_Already_Matched
;
25288 ----------------------------
25289 -- Is_In_Out_State_Clause --
25290 ----------------------------
25292 function Is_In_Out_State_Clause
return Boolean is
25293 Dep_Input_Id
: Entity_Id
;
25294 Dep_Output_Id
: Entity_Id
;
25297 -- Detect the following clause:
25300 if Is_Entity_Name
(Dep_Input
)
25301 and then Is_Entity_Name
(Dep_Output
)
25303 -- Handle abstract views generated for limited with clauses
25305 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
25306 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
25309 Ekind
(Dep_Input_Id
) = E_Abstract_State
25310 and then Dep_Input_Id
= Dep_Output_Id
;
25314 end Is_In_Out_State_Clause
;
25316 ---------------------------
25317 -- Is_Null_Refined_State --
25318 ---------------------------
25320 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
25321 Item_Id
: Entity_Id
;
25324 if Is_Entity_Name
(Item
) then
25326 -- Handle abstract views generated for limited with clauses
25328 Item_Id
:= Available_View
(Entity_Of
(Item
));
25331 Ekind
(Item_Id
) = E_Abstract_State
25332 and then Has_Null_Visible_Refinement
(Item_Id
);
25336 end Is_Null_Refined_State
;
25342 procedure Match_Items
25343 (Dep_Item
: Node_Id
;
25344 Ref_Item
: Node_Id
;
25345 Matched
: out Boolean)
25347 Dep_Item_Id
: Entity_Id
;
25348 Ref_Item_Id
: Entity_Id
;
25351 -- Assume that the two items do not match
25355 -- A null matches null or Empty (special case)
25357 if Nkind
(Dep_Item
) = N_Null
25358 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
25362 -- Attribute 'Result matches attribute 'Result
25364 elsif Is_Attribute_Result
(Dep_Item
)
25365 and then Is_Attribute_Result
(Ref_Item
)
25367 -- Put the entity of the related function on the list of
25368 -- matched items because attribute 'Result does not carry
25369 -- an entity similar to states and constituents.
25371 Record_Item
(Spec_Id
);
25374 -- Abstract states, current instances of concurrent types,
25375 -- discriminants, formal parameters and objects.
25377 elsif Is_Entity_Name
(Dep_Item
) then
25379 -- Handle abstract views generated for limited with clauses
25381 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25383 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
25385 -- An abstract state with visible null refinement matches
25386 -- null or Empty (special case).
25388 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
25389 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
25391 Record_Item
(Dep_Item_Id
);
25394 -- An abstract state with visible non-null refinement
25395 -- matches one of its constituents, or itself for an
25396 -- abstract state with partial visible refinement.
25398 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
25399 if Is_Entity_Name
(Ref_Item
) then
25400 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
25402 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
25405 and then Present
(Encapsulating_State
(Ref_Item_Id
))
25406 and then Find_Encapsulating_State
25407 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
25409 Record_Item
(Dep_Item_Id
);
25412 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
25413 and then Ref_Item_Id
= Dep_Item_Id
25415 Record_Item
(Dep_Item_Id
);
25420 -- An abstract state without a visible refinement matches
25423 elsif Is_Entity_Name
(Ref_Item
)
25424 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25426 Record_Item
(Dep_Item_Id
);
25430 -- A current instance of a concurrent type, discriminant,
25431 -- formal parameter or an object matches itself.
25433 elsif Is_Entity_Name
(Ref_Item
)
25434 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25436 Record_Item
(Dep_Item_Id
);
25446 procedure Record_Item
(Item_Id
: Entity_Id
) is
25448 if No
(Matched_Items
) then
25449 Matched_Items
:= New_Elmt_List
;
25452 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
25457 Clause_Matched
: Boolean := False;
25458 Dummy
: Boolean := False;
25459 Inputs_Match
: Boolean;
25460 Next_Ref_Clause
: Node_Id
;
25461 Outputs_Match
: Boolean;
25462 Ref_Clause
: Node_Id
;
25463 Ref_Input
: Node_Id
;
25464 Ref_Output
: Node_Id
;
25466 -- Start of processing for Check_Dependency_Clause
25469 -- Do not perform this check in an instance because it was already
25470 -- performed successfully in the generic template.
25472 if Is_Generic_Instance
(Spec_Id
) then
25476 -- Examine all refinement clauses and compare them against the
25477 -- dependence clause.
25479 Ref_Clause
:= First
(Refinements
);
25480 while Present
(Ref_Clause
) loop
25481 Next_Ref_Clause
:= Next
(Ref_Clause
);
25483 -- Obtain the attributes of the current refinement clause
25485 Ref_Input
:= Expression
(Ref_Clause
);
25486 Ref_Output
:= First
(Choices
(Ref_Clause
));
25488 -- The current refinement clause matches the dependence clause
25489 -- when both outputs match and both inputs match. See routine
25490 -- Match_Items for all possible conformance scenarios.
25492 -- Depends Dep_Output => Dep_Input
25496 -- Refined_Depends Ref_Output => Ref_Input
25499 (Dep_Item
=> Dep_Input
,
25500 Ref_Item
=> Ref_Input
,
25501 Matched
=> Inputs_Match
);
25504 (Dep_Item
=> Dep_Output
,
25505 Ref_Item
=> Ref_Output
,
25506 Matched
=> Outputs_Match
);
25508 -- An In_Out state clause may be matched against a refinement with
25509 -- a null input or null output as long as the non-null side of the
25510 -- relation contains a valid constituent of the In_Out_State.
25512 if Is_In_Out_State_Clause
then
25514 -- Depends => (State => State)
25515 -- Refined_Depends => (null => Constit) -- OK
25518 and then not Outputs_Match
25519 and then Nkind
(Ref_Output
) = N_Null
25521 Outputs_Match
:= True;
25524 -- Depends => (State => State)
25525 -- Refined_Depends => (Constit => null) -- OK
25527 if not Inputs_Match
25528 and then Outputs_Match
25529 and then Nkind
(Ref_Input
) = N_Null
25531 Inputs_Match
:= True;
25535 -- The current refinement clause is legally constructed following
25536 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25537 -- the pool of candidates. The seach continues because a single
25538 -- dependence clause may have multiple matching refinements.
25540 if Inputs_Match
and Outputs_Match
then
25541 Clause_Matched
:= True;
25542 Remove
(Ref_Clause
);
25545 Ref_Clause
:= Next_Ref_Clause
;
25548 -- Depending on the order or composition of refinement clauses, an
25549 -- In_Out state clause may not be directly refinable.
25551 -- Refined_State => (State => (Constit_1, Constit_2))
25552 -- Depends => ((Output, State) => (Input, State))
25553 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25555 -- Matching normalized clause (State => State) fails because there is
25556 -- no direct refinement capable of satisfying this relation. Another
25557 -- similar case arises when clauses (Constit_1 => Input) and (Output
25558 -- => Constit_2) are matched first, leaving no candidates for clause
25559 -- (State => State). Both scenarios are legal as long as one of the
25560 -- previous clauses mentioned a valid constituent of State.
25562 if not Clause_Matched
25563 and then Is_In_Out_State_Clause
25564 and then Is_Already_Matched
(Dep_Input
)
25566 Clause_Matched
:= True;
25569 -- A clause where the input is an abstract state with visible null
25570 -- refinement or a 'Result attribute is implicitly matched when the
25571 -- output has already been matched in a previous clause.
25573 -- Refined_State => (State => null)
25574 -- Depends => (Output => State) -- implicitly OK
25575 -- Refined_Depends => (Output => ...)
25576 -- Depends => (...'Result => State) -- implicitly OK
25577 -- Refined_Depends => (...'Result => ...)
25579 if not Clause_Matched
25580 and then Is_Null_Refined_State
(Dep_Input
)
25581 and then Is_Already_Matched
(Dep_Output
)
25583 Clause_Matched
:= True;
25586 -- A clause where the output is an abstract state with visible null
25587 -- refinement is implicitly matched when the input has already been
25588 -- matched in a previous clause.
25590 -- Refined_State => (State => null)
25591 -- Depends => (State => Input) -- implicitly OK
25592 -- Refined_Depends => (... => Input)
25594 if not Clause_Matched
25595 and then Is_Null_Refined_State
(Dep_Output
)
25596 and then Is_Already_Matched
(Dep_Input
)
25598 Clause_Matched
:= True;
25601 -- At this point either all refinement clauses have been examined or
25602 -- pragma Refined_Depends contains a solitary null. Only an abstract
25603 -- state with null refinement can possibly match these cases.
25605 -- Refined_State => (State => null)
25606 -- Depends => (State => null)
25607 -- Refined_Depends => null -- OK
25609 if not Clause_Matched
then
25611 (Dep_Item
=> Dep_Input
,
25613 Matched
=> Inputs_Match
);
25616 (Dep_Item
=> Dep_Output
,
25618 Matched
=> Outputs_Match
);
25620 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
25623 -- If the contents of Refined_Depends are legal, then the current
25624 -- dependence clause should be satisfied either by an explicit match
25625 -- or by one of the special cases.
25627 if not Clause_Matched
then
25629 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
25630 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
25632 end Check_Dependency_Clause
;
25634 -------------------------
25635 -- Check_Output_States --
25636 -------------------------
25638 procedure Check_Output_States
25639 (Spec_Id
: Entity_Id
;
25640 Spec_Inputs
: Elist_Id
;
25641 Spec_Outputs
: Elist_Id
;
25642 Body_Inputs
: Elist_Id
;
25643 Body_Outputs
: Elist_Id
)
25645 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25646 -- Determine whether all constituents of state State_Id with full
25647 -- visible refinement are used as outputs in pragma Refined_Depends.
25648 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
25650 -----------------------------
25651 -- Check_Constituent_Usage --
25652 -----------------------------
25654 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25655 Constits
: constant Elist_Id
:=
25656 Partial_Refinement_Constituents
(State_Id
);
25657 Constit_Elmt
: Elmt_Id
;
25658 Constit_Id
: Entity_Id
;
25659 Only_Partial
: constant Boolean :=
25660 not Has_Visible_Refinement
(State_Id
);
25661 Posted
: Boolean := False;
25664 if Present
(Constits
) then
25665 Constit_Elmt
:= First_Elmt
(Constits
);
25666 while Present
(Constit_Elmt
) loop
25667 Constit_Id
:= Node
(Constit_Elmt
);
25669 -- Issue an error when a constituent of State_Id is used,
25670 -- and State_Id has only partial visible refinement
25671 -- (SPARK RM 7.2.4(3d)).
25673 if Only_Partial
then
25674 if (Present
(Body_Inputs
)
25675 and then Appears_In
(Body_Inputs
, Constit_Id
))
25677 (Present
(Body_Outputs
)
25678 and then Appears_In
(Body_Outputs
, Constit_Id
))
25680 Error_Msg_Name_1
:= Chars
(State_Id
);
25682 ("constituent & of state % cannot be used in "
25683 & "dependence refinement", N
, Constit_Id
);
25684 Error_Msg_Name_1
:= Chars
(State_Id
);
25685 SPARK_Msg_N
("\use state % instead", N
);
25688 -- The constituent acts as an input (SPARK RM 7.2.5(3))
25690 elsif Present
(Body_Inputs
)
25691 and then Appears_In
(Body_Inputs
, Constit_Id
)
25693 Error_Msg_Name_1
:= Chars
(State_Id
);
25695 ("constituent & of state % must act as output in "
25696 & "dependence refinement", N
, Constit_Id
);
25698 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25700 elsif No
(Body_Outputs
)
25701 or else not Appears_In
(Body_Outputs
, Constit_Id
)
25706 ("output state & must be replaced by all its "
25707 & "constituents in dependence refinement",
25712 ("\constituent & is missing in output list",
25716 Next_Elmt
(Constit_Elmt
);
25719 end Check_Constituent_Usage
;
25724 Item_Elmt
: Elmt_Id
;
25725 Item_Id
: Entity_Id
;
25727 -- Start of processing for Check_Output_States
25730 -- Do not perform this check in an instance because it was already
25731 -- performed successfully in the generic template.
25733 if Is_Generic_Instance
(Spec_Id
) then
25736 -- Inspect the outputs of pragma Depends looking for a state with a
25737 -- visible refinement.
25739 elsif Present
(Spec_Outputs
) then
25740 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
25741 while Present
(Item_Elmt
) loop
25742 Item
:= Node
(Item_Elmt
);
25744 -- Deal with the mixed nature of the input and output lists
25746 if Nkind
(Item
) = N_Defining_Identifier
then
25749 Item_Id
:= Available_View
(Entity_Of
(Item
));
25752 if Ekind
(Item_Id
) = E_Abstract_State
then
25754 -- The state acts as an input-output, skip it
25756 if Present
(Spec_Inputs
)
25757 and then Appears_In
(Spec_Inputs
, Item_Id
)
25761 -- Ensure that all of the constituents are utilized as
25762 -- outputs in pragma Refined_Depends.
25764 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25765 Check_Constituent_Usage
(Item_Id
);
25769 Next_Elmt
(Item_Elmt
);
25772 end Check_Output_States
;
25774 --------------------
25775 -- Collect_States --
25776 --------------------
25778 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
25779 procedure Collect_State
25781 States
: in out Elist_Id
);
25782 -- Add the entity of Item to list States when it denotes to a state
25784 -------------------
25785 -- Collect_State --
25786 -------------------
25788 procedure Collect_State
25790 States
: in out Elist_Id
)
25795 if Is_Entity_Name
(Item
) then
25796 Id
:= Entity_Of
(Item
);
25798 if Ekind
(Id
) = E_Abstract_State
then
25799 if No
(States
) then
25800 States
:= New_Elmt_List
;
25803 Append_Unique_Elmt
(Id
, States
);
25813 States
: Elist_Id
:= No_Elist
;
25815 -- Start of processing for Collect_States
25818 Clause
:= First
(Clauses
);
25819 while Present
(Clause
) loop
25820 Input
:= Expression
(Clause
);
25821 Output
:= First
(Choices
(Clause
));
25823 Collect_State
(Input
, States
);
25824 Collect_State
(Output
, States
);
25830 end Collect_States
;
25832 -----------------------
25833 -- Normalize_Clauses --
25834 -----------------------
25836 procedure Normalize_Clauses
(Clauses
: List_Id
) is
25837 procedure Normalize_Inputs
(Clause
: Node_Id
);
25838 -- Normalize clause Clause by creating multiple clauses for each
25839 -- input item of Clause. It is assumed that Clause has exactly one
25840 -- output. The transformation is as follows:
25842 -- Output => (Input_1, Input_2) -- original
25844 -- Output => Input_1 -- normalizations
25845 -- Output => Input_2
25847 procedure Normalize_Outputs
(Clause
: Node_Id
);
25848 -- Normalize clause Clause by creating multiple clause for each
25849 -- output item of Clause. The transformation is as follows:
25851 -- (Output_1, Output_2) => Input -- original
25853 -- Output_1 => Input -- normalization
25854 -- Output_2 => Input
25856 ----------------------
25857 -- Normalize_Inputs --
25858 ----------------------
25860 procedure Normalize_Inputs
(Clause
: Node_Id
) is
25861 Inputs
: constant Node_Id
:= Expression
(Clause
);
25862 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25863 Output
: constant List_Id
:= Choices
(Clause
);
25864 Last_Input
: Node_Id
;
25866 New_Clause
: Node_Id
;
25867 Next_Input
: Node_Id
;
25870 -- Normalization is performed only when the original clause has
25871 -- more than one input. Multiple inputs appear as an aggregate.
25873 if Nkind
(Inputs
) = N_Aggregate
then
25874 Last_Input
:= Last
(Expressions
(Inputs
));
25876 -- Create a new clause for each input
25878 Input
:= First
(Expressions
(Inputs
));
25879 while Present
(Input
) loop
25880 Next_Input
:= Next
(Input
);
25882 -- Unhook the current input from the original input list
25883 -- because it will be relocated to a new clause.
25887 -- Special processing for the last input. At this point the
25888 -- original aggregate has been stripped down to one element.
25889 -- Replace the aggregate by the element itself.
25891 if Input
= Last_Input
then
25892 Rewrite
(Inputs
, Input
);
25894 -- Generate a clause of the form:
25899 Make_Component_Association
(Loc
,
25900 Choices
=> New_Copy_List_Tree
(Output
),
25901 Expression
=> Input
);
25903 -- The new clause contains replicated content that has
25904 -- already been analyzed, mark the clause as analyzed.
25906 Set_Analyzed
(New_Clause
);
25907 Insert_After
(Clause
, New_Clause
);
25910 Input
:= Next_Input
;
25913 end Normalize_Inputs
;
25915 -----------------------
25916 -- Normalize_Outputs --
25917 -----------------------
25919 procedure Normalize_Outputs
(Clause
: Node_Id
) is
25920 Inputs
: constant Node_Id
:= Expression
(Clause
);
25921 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25922 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
25923 Last_Output
: Node_Id
;
25924 New_Clause
: Node_Id
;
25925 Next_Output
: Node_Id
;
25929 -- Multiple outputs appear as an aggregate. Nothing to do when
25930 -- the clause has exactly one output.
25932 if Nkind
(Outputs
) = N_Aggregate
then
25933 Last_Output
:= Last
(Expressions
(Outputs
));
25935 -- Create a clause for each output. Note that each time a new
25936 -- clause is created, the original output list slowly shrinks
25937 -- until there is one item left.
25939 Output
:= First
(Expressions
(Outputs
));
25940 while Present
(Output
) loop
25941 Next_Output
:= Next
(Output
);
25943 -- Unhook the output from the original output list as it
25944 -- will be relocated to a new clause.
25948 -- Special processing for the last output. At this point
25949 -- the original aggregate has been stripped down to one
25950 -- element. Replace the aggregate by the element itself.
25952 if Output
= Last_Output
then
25953 Rewrite
(Outputs
, Output
);
25956 -- Generate a clause of the form:
25957 -- (Output => Inputs)
25960 Make_Component_Association
(Loc
,
25961 Choices
=> New_List
(Output
),
25962 Expression
=> New_Copy_Tree
(Inputs
));
25964 -- The new clause contains replicated content that has
25965 -- already been analyzed. There is not need to reanalyze
25968 Set_Analyzed
(New_Clause
);
25969 Insert_After
(Clause
, New_Clause
);
25972 Output
:= Next_Output
;
25975 end Normalize_Outputs
;
25981 -- Start of processing for Normalize_Clauses
25984 Clause
:= First
(Clauses
);
25985 while Present
(Clause
) loop
25986 Normalize_Outputs
(Clause
);
25990 Clause
:= First
(Clauses
);
25991 while Present
(Clause
) loop
25992 Normalize_Inputs
(Clause
);
25995 end Normalize_Clauses
;
25997 --------------------------
25998 -- Remove_Extra_Clauses --
25999 --------------------------
26001 procedure Remove_Extra_Clauses
26002 (Clauses
: List_Id
;
26003 Matched_Items
: Elist_Id
)
26007 Input_Id
: Entity_Id
;
26008 Next_Clause
: Node_Id
;
26010 State_Id
: Entity_Id
;
26013 Clause
:= First
(Clauses
);
26014 while Present
(Clause
) loop
26015 Next_Clause
:= Next
(Clause
);
26017 Input
:= Expression
(Clause
);
26018 Output
:= First
(Choices
(Clause
));
26020 -- Recognize a clause of the form
26024 -- where Input is a constituent of a state which was already
26025 -- successfully matched. This clause must be removed because it
26026 -- simply indicates that some of the constituents of the state
26029 -- Refined_State => (State => (Constit_1, Constit_2))
26030 -- Depends => (Output => State)
26031 -- Refined_Depends => ((Output => Constit_1), -- State matched
26032 -- (null => Constit_2)) -- OK
26034 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
26036 -- Handle abstract views generated for limited with clauses
26038 Input_Id
:= Available_View
(Entity_Of
(Input
));
26040 -- The input must be a constituent of a state
26042 if Ekind_In
(Input_Id
, E_Abstract_State
,
26045 and then Present
(Encapsulating_State
(Input_Id
))
26047 State_Id
:= Encapsulating_State
(Input_Id
);
26049 -- The state must have a non-null visible refinement and be
26050 -- matched in a previous clause.
26052 if Has_Non_Null_Visible_Refinement
(State_Id
)
26053 and then Contains
(Matched_Items
, State_Id
)
26059 -- Recognize a clause of the form
26063 -- where Output is an arbitrary item. This clause must be removed
26064 -- because a null input legitimately matches anything.
26066 elsif Nkind
(Input
) = N_Null
then
26070 Clause
:= Next_Clause
;
26072 end Remove_Extra_Clauses
;
26074 --------------------------
26075 -- Report_Extra_Clauses --
26076 --------------------------
26078 procedure Report_Extra_Clauses
26079 (Spec_Id
: Entity_Id
;
26085 -- Do not perform this check in an instance because it was already
26086 -- performed successfully in the generic template.
26088 if Is_Generic_Instance
(Spec_Id
) then
26091 elsif Present
(Clauses
) then
26092 Clause
:= First
(Clauses
);
26093 while Present
(Clause
) loop
26095 ("unmatched or extra clause in dependence refinement",
26101 end Report_Extra_Clauses
;
26105 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26106 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26107 Errors
: constant Nat
:= Serious_Errors_Detected
;
26114 Body_Inputs
: Elist_Id
:= No_Elist
;
26115 Body_Outputs
: Elist_Id
:= No_Elist
;
26116 -- The inputs and outputs of the subprogram body synthesized from pragma
26117 -- Refined_Depends.
26119 Dependencies
: List_Id
:= No_List
;
26121 -- The corresponding Depends pragma along with its clauses
26123 Matched_Items
: Elist_Id
:= No_Elist
;
26124 -- A list containing the entities of all successfully matched items
26125 -- found in pragma Depends.
26127 Refinements
: List_Id
:= No_List
;
26128 -- The clauses of pragma Refined_Depends
26130 Spec_Id
: Entity_Id
;
26131 -- The entity of the subprogram subject to pragma Refined_Depends
26133 Spec_Inputs
: Elist_Id
:= No_Elist
;
26134 Spec_Outputs
: Elist_Id
:= No_Elist
;
26135 -- The inputs and outputs of the subprogram spec synthesized from pragma
26138 States
: Elist_Id
:= No_Elist
;
26139 -- A list containing the entities of all states whose constituents
26140 -- appear in pragma Depends.
26142 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26145 -- Do not analyze the pragma multiple times
26147 if Is_Analyzed_Pragma
(N
) then
26151 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26153 -- Use the anonymous object as the proper spec when Refined_Depends
26154 -- applies to the body of a single task type. The object carries the
26155 -- proper Chars as well as all non-refined versions of pragmas.
26157 if Is_Single_Concurrent_Type
(Spec_Id
) then
26158 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26161 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26163 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26164 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26166 if No
(Depends
) then
26168 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26169 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
26173 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26175 -- A null dependency relation renders the refinement useless because it
26176 -- cannot possibly mention abstract states with visible refinement. Note
26177 -- that the inverse is not true as states may be refined to null
26178 -- (SPARK RM 7.2.5(2)).
26180 if Nkind
(Deps
) = N_Null
then
26182 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26183 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
26187 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26188 -- This ensures that the categorization of all refined dependency items
26189 -- is consistent with their role.
26191 Analyze_Depends_In_Decl_Part
(N
);
26193 -- Do not match dependencies against refinements if Refined_Depends is
26194 -- illegal to avoid emitting misleading error.
26196 if Serious_Errors_Detected
= Errors
then
26198 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26199 -- the inputs and outputs of the subprogram spec and body to verify
26200 -- the use of states with visible refinement and their constituents.
26202 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
26203 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
26205 Collect_Subprogram_Inputs_Outputs
26206 (Subp_Id
=> Spec_Id
,
26207 Synthesize
=> True,
26208 Subp_Inputs
=> Spec_Inputs
,
26209 Subp_Outputs
=> Spec_Outputs
,
26210 Global_Seen
=> Dummy
);
26212 Collect_Subprogram_Inputs_Outputs
26213 (Subp_Id
=> Body_Id
,
26214 Synthesize
=> True,
26215 Subp_Inputs
=> Body_Inputs
,
26216 Subp_Outputs
=> Body_Outputs
,
26217 Global_Seen
=> Dummy
);
26219 -- For an output state with a visible refinement, ensure that all
26220 -- constituents appear as outputs in the dependency refinement.
26222 Check_Output_States
26223 (Spec_Id
=> Spec_Id
,
26224 Spec_Inputs
=> Spec_Inputs
,
26225 Spec_Outputs
=> Spec_Outputs
,
26226 Body_Inputs
=> Body_Inputs
,
26227 Body_Outputs
=> Body_Outputs
);
26230 -- Matching is disabled in ASIS because clauses are not normalized as
26231 -- this is a tree altering activity similar to expansion.
26237 -- Multiple dependency clauses appear as component associations of an
26238 -- aggregate. Note that the clauses are copied because the algorithm
26239 -- modifies them and this should not be visible in Depends.
26241 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
26242 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
26243 Normalize_Clauses
(Dependencies
);
26245 -- Gather all states which appear in Depends
26247 States
:= Collect_States
(Dependencies
);
26249 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
26251 if Nkind
(Refs
) = N_Null
then
26252 Refinements
:= No_List
;
26254 -- Multiple dependency clauses appear as component associations of an
26255 -- aggregate. Note that the clauses are copied because the algorithm
26256 -- modifies them and this should not be visible in Refined_Depends.
26258 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
26259 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
26260 Normalize_Clauses
(Refinements
);
26263 -- At this point the clauses of pragmas Depends and Refined_Depends
26264 -- have been normalized into simple dependencies between one output
26265 -- and one input. Examine all clauses of pragma Depends looking for
26266 -- matching clauses in pragma Refined_Depends.
26268 Clause
:= First
(Dependencies
);
26269 while Present
(Clause
) loop
26270 Check_Dependency_Clause
26271 (Spec_Id
=> Spec_Id
,
26272 Dep_Clause
=> Clause
,
26273 Dep_States
=> States
,
26274 Refinements
=> Refinements
,
26275 Matched_Items
=> Matched_Items
);
26280 -- Pragma Refined_Depends may contain multiple clarification clauses
26281 -- which indicate that certain constituents do not influence the data
26282 -- flow in any way. Such clauses must be removed as long as the state
26283 -- has been matched, otherwise they will be incorrectly flagged as
26286 -- Refined_State => (State => (Constit_1, Constit_2))
26287 -- Depends => (Output => State)
26288 -- Refined_Depends => ((Output => Constit_1), -- State matched
26289 -- (null => Constit_2)) -- must be removed
26291 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
26293 if Serious_Errors_Detected
= Errors
then
26294 Report_Extra_Clauses
(Spec_Id
, Refinements
);
26299 Set_Is_Analyzed_Pragma
(N
);
26300 end Analyze_Refined_Depends_In_Decl_Part
;
26302 -----------------------------------------
26303 -- Analyze_Refined_Global_In_Decl_Part --
26304 -----------------------------------------
26306 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
26308 -- The corresponding Global pragma
26310 Has_In_State
: Boolean := False;
26311 Has_In_Out_State
: Boolean := False;
26312 Has_Out_State
: Boolean := False;
26313 Has_Proof_In_State
: Boolean := False;
26314 -- These flags are set when the corresponding Global pragma has a state
26315 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
26318 Has_Null_State
: Boolean := False;
26319 -- This flag is set when the corresponding Global pragma has at least
26320 -- one state with a null refinement.
26322 In_Constits
: Elist_Id
:= No_Elist
;
26323 In_Out_Constits
: Elist_Id
:= No_Elist
;
26324 Out_Constits
: Elist_Id
:= No_Elist
;
26325 Proof_In_Constits
: Elist_Id
:= No_Elist
;
26326 -- These lists contain the entities of all Input, In_Out, Output and
26327 -- Proof_In constituents that appear in Refined_Global and participate
26328 -- in state refinement.
26330 In_Items
: Elist_Id
:= No_Elist
;
26331 In_Out_Items
: Elist_Id
:= No_Elist
;
26332 Out_Items
: Elist_Id
:= No_Elist
;
26333 Proof_In_Items
: Elist_Id
:= No_Elist
;
26334 -- These lists contain the entities of all Input, In_Out, Output and
26335 -- Proof_In items defined in the corresponding Global pragma.
26337 Repeat_Items
: Elist_Id
:= No_Elist
;
26338 -- A list of all global items without full visible refinement found
26339 -- in pragma Global. These states should be repeated in the global
26340 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
26341 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
26343 Spec_Id
: Entity_Id
;
26344 -- The entity of the subprogram subject to pragma Refined_Global
26346 States
: Elist_Id
:= No_Elist
;
26347 -- A list of all states with full or partial visible refinement found in
26350 procedure Check_In_Out_States
;
26351 -- Determine whether the corresponding Global pragma mentions In_Out
26352 -- states with visible refinement and if so, ensure that one of the
26353 -- following completions apply to the constituents of the state:
26354 -- 1) there is at least one constituent of mode In_Out
26355 -- 2) there is at least one Input and one Output constituent
26356 -- 3) not all constituents are present and one of them is of mode
26358 -- This routine may remove elements from In_Constits, In_Out_Constits,
26359 -- Out_Constits and Proof_In_Constits.
26361 procedure Check_Input_States
;
26362 -- Determine whether the corresponding Global pragma mentions Input
26363 -- states with visible refinement and if so, ensure that at least one of
26364 -- its constituents appears as an Input item in Refined_Global.
26365 -- This routine may remove elements from In_Constits, In_Out_Constits,
26366 -- Out_Constits and Proof_In_Constits.
26368 procedure Check_Output_States
;
26369 -- Determine whether the corresponding Global pragma mentions Output
26370 -- states with visible refinement and if so, ensure that all of its
26371 -- constituents appear as Output items in Refined_Global.
26372 -- This routine may remove elements from In_Constits, In_Out_Constits,
26373 -- Out_Constits and Proof_In_Constits.
26375 procedure Check_Proof_In_States
;
26376 -- Determine whether the corresponding Global pragma mentions Proof_In
26377 -- states with visible refinement and if so, ensure that at least one of
26378 -- its constituents appears as a Proof_In item in Refined_Global.
26379 -- This routine may remove elements from In_Constits, In_Out_Constits,
26380 -- Out_Constits and Proof_In_Constits.
26382 procedure Check_Refined_Global_List
26384 Global_Mode
: Name_Id
:= Name_Input
);
26385 -- Verify the legality of a single global list declaration. Global_Mode
26386 -- denotes the current mode in effect.
26388 procedure Collect_Global_Items
26390 Mode
: Name_Id
:= Name_Input
);
26391 -- Gather all Input, In_Out, Output and Proof_In items from node List
26392 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
26393 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
26394 -- and Has_Proof_In_State are set when there is at least one abstract
26395 -- state with full or partial visible refinement available in the
26396 -- corresponding mode. Flag Has_Null_State is set when at least state
26397 -- has a null refinement. Mode denotes the current global mode in
26400 function Present_Then_Remove
26402 Item
: Entity_Id
) return Boolean;
26403 -- Search List for a particular entity Item. If Item has been found,
26404 -- remove it from List. This routine is used to strip lists In_Constits,
26405 -- In_Out_Constits and Out_Constits of valid constituents.
26407 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
26408 -- Same as function Present_Then_Remove, but do not report the presence
26409 -- of Item in List.
26411 procedure Report_Extra_Constituents
;
26412 -- Emit an error for each constituent found in lists In_Constits,
26413 -- In_Out_Constits and Out_Constits.
26415 procedure Report_Missing_Items
;
26416 -- Emit an error for each global item not repeated found in list
26419 -------------------------
26420 -- Check_In_Out_States --
26421 -------------------------
26423 procedure Check_In_Out_States
is
26424 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26425 -- Determine whether one of the following coverage scenarios is in
26427 -- 1) there is at least one constituent of mode In_Out or Output
26428 -- 2) there is at least one pair of constituents with modes Input
26429 -- and Output, or Proof_In and Output.
26430 -- 3) there is at least one constituent of mode Output and not all
26431 -- constituents are present.
26432 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
26434 -----------------------------
26435 -- Check_Constituent_Usage --
26436 -----------------------------
26438 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26439 Constits
: constant Elist_Id
:=
26440 Partial_Refinement_Constituents
(State_Id
);
26441 Constit_Elmt
: Elmt_Id
;
26442 Constit_Id
: Entity_Id
;
26443 Has_Missing
: Boolean := False;
26444 In_Out_Seen
: Boolean := False;
26445 Input_Seen
: Boolean := False;
26446 Output_Seen
: Boolean := False;
26447 Proof_In_Seen
: Boolean := False;
26450 -- Process all the constituents of the state and note their modes
26451 -- within the global refinement.
26453 if Present
(Constits
) then
26454 Constit_Elmt
:= First_Elmt
(Constits
);
26455 while Present
(Constit_Elmt
) loop
26456 Constit_Id
:= Node
(Constit_Elmt
);
26458 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26459 Input_Seen
:= True;
26461 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
26462 In_Out_Seen
:= True;
26464 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26465 Output_Seen
:= True;
26467 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26469 Proof_In_Seen
:= True;
26472 Has_Missing
:= True;
26475 Next_Elmt
(Constit_Elmt
);
26479 -- An In_Out constituent is a valid completion
26481 if In_Out_Seen
then
26484 -- A pair of one Input/Proof_In and one Output constituent is a
26485 -- valid completion.
26487 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
26490 elsif Output_Seen
then
26492 -- A single Output constituent is a valid completion only when
26493 -- some of the other constituents are missing.
26495 if Has_Missing
then
26498 -- Otherwise all constituents are of mode Output
26502 ("global refinement of state & must include at least one "
26503 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26507 -- The state lacks a completion. When full refinement is visible,
26508 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26509 -- refinement is visible, emit an error if the abstract state
26510 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26511 -- both are utilized, Check_State_And_Constituent_Use. will issue
26514 elsif not Input_Seen
26515 and then not In_Out_Seen
26516 and then not Output_Seen
26517 and then not Proof_In_Seen
26519 if Has_Visible_Refinement
(State_Id
)
26520 or else Contains
(Repeat_Items
, State_Id
)
26523 ("missing global refinement of state &", N
, State_Id
);
26526 -- Otherwise the state has a malformed completion where at least
26527 -- one of the constituents has a different mode.
26531 ("global refinement of state & redefines the mode of its "
26532 & "constituents", N
, State_Id
);
26534 end Check_Constituent_Usage
;
26538 Item_Elmt
: Elmt_Id
;
26539 Item_Id
: Entity_Id
;
26541 -- Start of processing for Check_In_Out_States
26544 -- Do not perform this check in an instance because it was already
26545 -- performed successfully in the generic template.
26547 if Is_Generic_Instance
(Spec_Id
) then
26550 -- Inspect the In_Out items of the corresponding Global pragma
26551 -- looking for a state with a visible refinement.
26553 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
26554 Item_Elmt
:= First_Elmt
(In_Out_Items
);
26555 while Present
(Item_Elmt
) loop
26556 Item_Id
:= Node
(Item_Elmt
);
26558 -- Ensure that one of the three coverage variants is satisfied
26560 if Ekind
(Item_Id
) = E_Abstract_State
26561 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26563 Check_Constituent_Usage
(Item_Id
);
26566 Next_Elmt
(Item_Elmt
);
26569 end Check_In_Out_States
;
26571 ------------------------
26572 -- Check_Input_States --
26573 ------------------------
26575 procedure Check_Input_States
is
26576 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26577 -- Determine whether at least one constituent of state State_Id with
26578 -- full or partial visible refinement is used and has mode Input.
26579 -- Ensure that the remaining constituents do not have In_Out or
26580 -- Output modes. Emit an error if this is not the case
26581 -- (SPARK RM 7.2.4(5)).
26583 -----------------------------
26584 -- Check_Constituent_Usage --
26585 -----------------------------
26587 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26588 Constits
: constant Elist_Id
:=
26589 Partial_Refinement_Constituents
(State_Id
);
26590 Constit_Elmt
: Elmt_Id
;
26591 Constit_Id
: Entity_Id
;
26592 In_Seen
: Boolean := False;
26595 if Present
(Constits
) then
26596 Constit_Elmt
:= First_Elmt
(Constits
);
26597 while Present
(Constit_Elmt
) loop
26598 Constit_Id
:= Node
(Constit_Elmt
);
26600 -- At least one of the constituents appears as an Input
26602 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26605 -- A Proof_In constituent can refine an Input state as long
26606 -- as there is at least one Input constituent present.
26608 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26612 -- The constituent appears in the global refinement, but has
26613 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
26615 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26616 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26618 Error_Msg_Name_1
:= Chars
(State_Id
);
26620 ("constituent & of state % must have mode `Input` in "
26621 & "global refinement", N
, Constit_Id
);
26624 Next_Elmt
(Constit_Elmt
);
26628 -- Not one of the constituents appeared as Input. Always emit an
26629 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
26630 -- When only partial refinement is visible, emit an error if the
26631 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26632 -- the case where both are utilized, an error will be issued in
26633 -- Check_State_And_Constituent_Use.
26636 and then (Has_Visible_Refinement
(State_Id
)
26637 or else Contains
(Repeat_Items
, State_Id
))
26640 ("global refinement of state & must include at least one "
26641 & "constituent of mode `Input`", N
, State_Id
);
26643 end Check_Constituent_Usage
;
26647 Item_Elmt
: Elmt_Id
;
26648 Item_Id
: Entity_Id
;
26650 -- Start of processing for Check_Input_States
26653 -- Do not perform this check in an instance because it was already
26654 -- performed successfully in the generic template.
26656 if Is_Generic_Instance
(Spec_Id
) then
26659 -- Inspect the Input items of the corresponding Global pragma looking
26660 -- for a state with a visible refinement.
26662 elsif Has_In_State
and then Present
(In_Items
) then
26663 Item_Elmt
:= First_Elmt
(In_Items
);
26664 while Present
(Item_Elmt
) loop
26665 Item_Id
:= Node
(Item_Elmt
);
26667 -- When full refinement is visible, ensure that at least one of
26668 -- the constituents is utilized and is of mode Input. When only
26669 -- partial refinement is visible, ensure that either one of
26670 -- the constituents is utilized and is of mode Input, or the
26671 -- abstract state is repeated and no constituent is utilized.
26673 if Ekind
(Item_Id
) = E_Abstract_State
26674 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26676 Check_Constituent_Usage
(Item_Id
);
26679 Next_Elmt
(Item_Elmt
);
26682 end Check_Input_States
;
26684 -------------------------
26685 -- Check_Output_States --
26686 -------------------------
26688 procedure Check_Output_States
is
26689 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26690 -- Determine whether all constituents of state State_Id with full
26691 -- visible refinement are used and have mode Output. Emit an error
26692 -- if this is not the case (SPARK RM 7.2.4(5)).
26694 -----------------------------
26695 -- Check_Constituent_Usage --
26696 -----------------------------
26698 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26699 Constits
: constant Elist_Id
:=
26700 Partial_Refinement_Constituents
(State_Id
);
26701 Only_Partial
: constant Boolean :=
26702 not Has_Visible_Refinement
(State_Id
);
26703 Constit_Elmt
: Elmt_Id
;
26704 Constit_Id
: Entity_Id
;
26705 Posted
: Boolean := False;
26708 if Present
(Constits
) then
26709 Constit_Elmt
:= First_Elmt
(Constits
);
26710 while Present
(Constit_Elmt
) loop
26711 Constit_Id
:= Node
(Constit_Elmt
);
26713 -- Issue an error when a constituent of State_Id is utilized
26714 -- and State_Id has only partial visible refinement
26715 -- (SPARK RM 7.2.4(3d)).
26717 if Only_Partial
then
26718 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
26719 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
26721 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26723 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26725 Error_Msg_Name_1
:= Chars
(State_Id
);
26727 ("constituent & of state % cannot be used in global "
26728 & "refinement", N
, Constit_Id
);
26729 Error_Msg_Name_1
:= Chars
(State_Id
);
26730 SPARK_Msg_N
("\use state % instead", N
);
26733 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26736 -- The constituent appears in the global refinement, but has
26737 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
26739 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26740 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26741 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26743 Error_Msg_Name_1
:= Chars
(State_Id
);
26745 ("constituent & of state % must have mode `Output` in "
26746 & "global refinement", N
, Constit_Id
);
26748 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26754 ("`Output` state & must be replaced by all its "
26755 & "constituents in global refinement", N
, State_Id
);
26759 ("\constituent & is missing in output list",
26763 Next_Elmt
(Constit_Elmt
);
26766 end Check_Constituent_Usage
;
26770 Item_Elmt
: Elmt_Id
;
26771 Item_Id
: Entity_Id
;
26773 -- Start of processing for Check_Output_States
26776 -- Do not perform this check in an instance because it was already
26777 -- performed successfully in the generic template.
26779 if Is_Generic_Instance
(Spec_Id
) then
26782 -- Inspect the Output items of the corresponding Global pragma
26783 -- looking for a state with a visible refinement.
26785 elsif Has_Out_State
and then Present
(Out_Items
) then
26786 Item_Elmt
:= First_Elmt
(Out_Items
);
26787 while Present
(Item_Elmt
) loop
26788 Item_Id
:= Node
(Item_Elmt
);
26790 -- When full refinement is visible, ensure that all of the
26791 -- constituents are utilized and they have mode Output. When
26792 -- only partial refinement is visible, ensure that no
26793 -- constituent is utilized.
26795 if Ekind
(Item_Id
) = E_Abstract_State
26796 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26798 Check_Constituent_Usage
(Item_Id
);
26801 Next_Elmt
(Item_Elmt
);
26804 end Check_Output_States
;
26806 ---------------------------
26807 -- Check_Proof_In_States --
26808 ---------------------------
26810 procedure Check_Proof_In_States
is
26811 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26812 -- Determine whether at least one constituent of state State_Id with
26813 -- full or partial visible refinement is used and has mode Proof_In.
26814 -- Ensure that the remaining constituents do not have Input, In_Out,
26815 -- or Output modes. Emit an error if this is not the case
26816 -- (SPARK RM 7.2.4(5)).
26818 -----------------------------
26819 -- Check_Constituent_Usage --
26820 -----------------------------
26822 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26823 Constits
: constant Elist_Id
:=
26824 Partial_Refinement_Constituents
(State_Id
);
26825 Constit_Elmt
: Elmt_Id
;
26826 Constit_Id
: Entity_Id
;
26827 Proof_In_Seen
: Boolean := False;
26830 if Present
(Constits
) then
26831 Constit_Elmt
:= First_Elmt
(Constits
);
26832 while Present
(Constit_Elmt
) loop
26833 Constit_Id
:= Node
(Constit_Elmt
);
26835 -- At least one of the constituents appears as Proof_In
26837 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
26838 Proof_In_Seen
:= True;
26840 -- The constituent appears in the global refinement, but has
26841 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
26843 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26844 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26845 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26847 Error_Msg_Name_1
:= Chars
(State_Id
);
26849 ("constituent & of state % must have mode `Proof_In` "
26850 & "in global refinement", N
, Constit_Id
);
26853 Next_Elmt
(Constit_Elmt
);
26857 -- Not one of the constituents appeared as Proof_In. Always emit
26858 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
26859 -- When only partial refinement is visible, emit an error if the
26860 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26861 -- the case where both are utilized, an error will be issued by
26862 -- Check_State_And_Constituent_Use.
26864 if not Proof_In_Seen
26865 and then (Has_Visible_Refinement
(State_Id
)
26866 or else Contains
(Repeat_Items
, State_Id
))
26869 ("global refinement of state & must include at least one "
26870 & "constituent of mode `Proof_In`", N
, State_Id
);
26872 end Check_Constituent_Usage
;
26876 Item_Elmt
: Elmt_Id
;
26877 Item_Id
: Entity_Id
;
26879 -- Start of processing for Check_Proof_In_States
26882 -- Do not perform this check in an instance because it was already
26883 -- performed successfully in the generic template.
26885 if Is_Generic_Instance
(Spec_Id
) then
26888 -- Inspect the Proof_In items of the corresponding Global pragma
26889 -- looking for a state with a visible refinement.
26891 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
26892 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
26893 while Present
(Item_Elmt
) loop
26894 Item_Id
:= Node
(Item_Elmt
);
26896 -- Ensure that at least one of the constituents is utilized
26897 -- and is of mode Proof_In. When only partial refinement is
26898 -- visible, ensure that either one of the constituents is
26899 -- utilized and is of mode Proof_In, or the abstract state
26900 -- is repeated and no constituent is utilized.
26902 if Ekind
(Item_Id
) = E_Abstract_State
26903 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26905 Check_Constituent_Usage
(Item_Id
);
26908 Next_Elmt
(Item_Elmt
);
26911 end Check_Proof_In_States
;
26913 -------------------------------
26914 -- Check_Refined_Global_List --
26915 -------------------------------
26917 procedure Check_Refined_Global_List
26919 Global_Mode
: Name_Id
:= Name_Input
)
26921 procedure Check_Refined_Global_Item
26923 Global_Mode
: Name_Id
);
26924 -- Verify the legality of a single global item declaration. Parameter
26925 -- Global_Mode denotes the current mode in effect.
26927 -------------------------------
26928 -- Check_Refined_Global_Item --
26929 -------------------------------
26931 procedure Check_Refined_Global_Item
26933 Global_Mode
: Name_Id
)
26935 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
26937 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
26938 -- Issue a common error message for all mode mismatches. Expect
26939 -- denotes the expected mode.
26941 -----------------------------
26942 -- Inconsistent_Mode_Error --
26943 -----------------------------
26945 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
26948 ("global item & has inconsistent modes", Item
, Item_Id
);
26950 Error_Msg_Name_1
:= Global_Mode
;
26951 Error_Msg_Name_2
:= Expect
;
26952 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
26953 end Inconsistent_Mode_Error
;
26957 Enc_State
: Entity_Id
:= Empty
;
26958 -- Encapsulating state for constituent, Empty otherwise
26960 -- Start of processing for Check_Refined_Global_Item
26963 if Ekind_In
(Item_Id
, E_Abstract_State
,
26967 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
26970 -- When the state or object acts as a constituent of another
26971 -- state with a visible refinement, collect it for the state
26972 -- completeness checks performed later on. Note that the item
26973 -- acts as a constituent only when the encapsulating state is
26974 -- present in pragma Global.
26976 if Present
(Enc_State
)
26977 and then (Has_Visible_Refinement
(Enc_State
)
26978 or else Has_Partial_Visible_Refinement
(Enc_State
))
26979 and then Contains
(States
, Enc_State
)
26981 -- If the state has only partial visible refinement, remove it
26982 -- from the list of items that should be repeated from pragma
26985 if not Has_Visible_Refinement
(Enc_State
) then
26986 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26989 if Global_Mode
= Name_Input
then
26990 Append_New_Elmt
(Item_Id
, In_Constits
);
26992 elsif Global_Mode
= Name_In_Out
then
26993 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26995 elsif Global_Mode
= Name_Output
then
26996 Append_New_Elmt
(Item_Id
, Out_Constits
);
26998 elsif Global_Mode
= Name_Proof_In
then
26999 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
27002 -- When not a constituent, ensure that both occurrences of the
27003 -- item in pragmas Global and Refined_Global match. Also remove
27004 -- it when present from the list of items that should be repeated
27005 -- from pragma Global.
27008 Present_Then_Remove
(Repeat_Items
, Item_Id
);
27010 if Contains
(In_Items
, Item_Id
) then
27011 if Global_Mode
/= Name_Input
then
27012 Inconsistent_Mode_Error
(Name_Input
);
27015 elsif Contains
(In_Out_Items
, Item_Id
) then
27016 if Global_Mode
/= Name_In_Out
then
27017 Inconsistent_Mode_Error
(Name_In_Out
);
27020 elsif Contains
(Out_Items
, Item_Id
) then
27021 if Global_Mode
/= Name_Output
then
27022 Inconsistent_Mode_Error
(Name_Output
);
27025 elsif Contains
(Proof_In_Items
, Item_Id
) then
27028 -- The item does not appear in the corresponding Global pragma,
27029 -- it must be an extra (SPARK RM 7.2.4(3)).
27032 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
27035 end Check_Refined_Global_Item
;
27041 -- Start of processing for Check_Refined_Global_List
27044 -- Do not perform this check in an instance because it was already
27045 -- performed successfully in the generic template.
27047 if Is_Generic_Instance
(Spec_Id
) then
27050 elsif Nkind
(List
) = N_Null
then
27053 -- Single global item declaration
27055 elsif Nkind_In
(List
, N_Expanded_Name
,
27057 N_Selected_Component
)
27059 Check_Refined_Global_Item
(List
, Global_Mode
);
27061 -- Simple global list or moded global list declaration
27063 elsif Nkind
(List
) = N_Aggregate
then
27065 -- The declaration of a simple global list appear as a collection
27068 if Present
(Expressions
(List
)) then
27069 Item
:= First
(Expressions
(List
));
27070 while Present
(Item
) loop
27071 Check_Refined_Global_Item
(Item
, Global_Mode
);
27075 -- The declaration of a moded global list appears as a collection
27076 -- of component associations where individual choices denote
27079 elsif Present
(Component_Associations
(List
)) then
27080 Item
:= First
(Component_Associations
(List
));
27081 while Present
(Item
) loop
27082 Check_Refined_Global_List
27083 (List
=> Expression
(Item
),
27084 Global_Mode
=> Chars
(First
(Choices
(Item
))));
27092 raise Program_Error
;
27098 raise Program_Error
;
27100 end Check_Refined_Global_List
;
27102 --------------------------
27103 -- Collect_Global_Items --
27104 --------------------------
27106 procedure Collect_Global_Items
27108 Mode
: Name_Id
:= Name_Input
)
27110 procedure Collect_Global_Item
27112 Item_Mode
: Name_Id
);
27113 -- Add a single item to the appropriate list. Item_Mode denotes the
27114 -- current mode in effect.
27116 -------------------------
27117 -- Collect_Global_Item --
27118 -------------------------
27120 procedure Collect_Global_Item
27122 Item_Mode
: Name_Id
)
27124 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
27125 -- The above handles abstract views of variables and states built
27126 -- for limited with clauses.
27129 -- Signal that the global list contains at least one abstract
27130 -- state with a visible refinement. Note that the refinement may
27131 -- be null in which case there are no constituents.
27133 if Ekind
(Item_Id
) = E_Abstract_State
then
27134 if Has_Null_Visible_Refinement
(Item_Id
) then
27135 Has_Null_State
:= True;
27137 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27138 Append_New_Elmt
(Item_Id
, States
);
27140 if Item_Mode
= Name_Input
then
27141 Has_In_State
:= True;
27142 elsif Item_Mode
= Name_In_Out
then
27143 Has_In_Out_State
:= True;
27144 elsif Item_Mode
= Name_Output
then
27145 Has_Out_State
:= True;
27146 elsif Item_Mode
= Name_Proof_In
then
27147 Has_Proof_In_State
:= True;
27152 -- Record global items without full visible refinement found in
27153 -- pragma Global which should be repeated in the global refinement
27154 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27156 if Ekind
(Item_Id
) /= E_Abstract_State
27157 or else not Has_Visible_Refinement
(Item_Id
)
27159 Append_New_Elmt
(Item_Id
, Repeat_Items
);
27162 -- Add the item to the proper list
27164 if Item_Mode
= Name_Input
then
27165 Append_New_Elmt
(Item_Id
, In_Items
);
27166 elsif Item_Mode
= Name_In_Out
then
27167 Append_New_Elmt
(Item_Id
, In_Out_Items
);
27168 elsif Item_Mode
= Name_Output
then
27169 Append_New_Elmt
(Item_Id
, Out_Items
);
27170 elsif Item_Mode
= Name_Proof_In
then
27171 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
27173 end Collect_Global_Item
;
27179 -- Start of processing for Collect_Global_Items
27182 if Nkind
(List
) = N_Null
then
27185 -- Single global item declaration
27187 elsif Nkind_In
(List
, N_Expanded_Name
,
27189 N_Selected_Component
)
27191 Collect_Global_Item
(List
, Mode
);
27193 -- Single global list or moded global list declaration
27195 elsif Nkind
(List
) = N_Aggregate
then
27197 -- The declaration of a simple global list appear as a collection
27200 if Present
(Expressions
(List
)) then
27201 Item
:= First
(Expressions
(List
));
27202 while Present
(Item
) loop
27203 Collect_Global_Item
(Item
, Mode
);
27207 -- The declaration of a moded global list appears as a collection
27208 -- of component associations where individual choices denote mode.
27210 elsif Present
(Component_Associations
(List
)) then
27211 Item
:= First
(Component_Associations
(List
));
27212 while Present
(Item
) loop
27213 Collect_Global_Items
27214 (List
=> Expression
(Item
),
27215 Mode
=> Chars
(First
(Choices
(Item
))));
27223 raise Program_Error
;
27226 -- To accommodate partial decoration of disabled SPARK features, this
27227 -- routine may be called with illegal input. If this is the case, do
27228 -- not raise Program_Error.
27233 end Collect_Global_Items
;
27235 -------------------------
27236 -- Present_Then_Remove --
27237 -------------------------
27239 function Present_Then_Remove
27241 Item
: Entity_Id
) return Boolean
27246 if Present
(List
) then
27247 Elmt
:= First_Elmt
(List
);
27248 while Present
(Elmt
) loop
27249 if Node
(Elmt
) = Item
then
27250 Remove_Elmt
(List
, Elmt
);
27259 end Present_Then_Remove
;
27261 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
27264 Ignore
:= Present_Then_Remove
(List
, Item
);
27265 end Present_Then_Remove
;
27267 -------------------------------
27268 -- Report_Extra_Constituents --
27269 -------------------------------
27271 procedure Report_Extra_Constituents
is
27272 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
27273 -- Emit an error for every element of List
27275 ---------------------------------------
27276 -- Report_Extra_Constituents_In_List --
27277 ---------------------------------------
27279 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
27280 Constit_Elmt
: Elmt_Id
;
27283 if Present
(List
) then
27284 Constit_Elmt
:= First_Elmt
(List
);
27285 while Present
(Constit_Elmt
) loop
27286 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
27287 Next_Elmt
(Constit_Elmt
);
27290 end Report_Extra_Constituents_In_List
;
27292 -- Start of processing for Report_Extra_Constituents
27295 -- Do not perform this check in an instance because it was already
27296 -- performed successfully in the generic template.
27298 if Is_Generic_Instance
(Spec_Id
) then
27302 Report_Extra_Constituents_In_List
(In_Constits
);
27303 Report_Extra_Constituents_In_List
(In_Out_Constits
);
27304 Report_Extra_Constituents_In_List
(Out_Constits
);
27305 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
27307 end Report_Extra_Constituents
;
27309 --------------------------
27310 -- Report_Missing_Items --
27311 --------------------------
27313 procedure Report_Missing_Items
is
27314 Item_Elmt
: Elmt_Id
;
27315 Item_Id
: Entity_Id
;
27318 -- Do not perform this check in an instance because it was already
27319 -- performed successfully in the generic template.
27321 if Is_Generic_Instance
(Spec_Id
) then
27325 if Present
(Repeat_Items
) then
27326 Item_Elmt
:= First_Elmt
(Repeat_Items
);
27327 while Present
(Item_Elmt
) loop
27328 Item_Id
:= Node
(Item_Elmt
);
27329 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
27330 Next_Elmt
(Item_Elmt
);
27334 end Report_Missing_Items
;
27338 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27339 Errors
: constant Nat
:= Serious_Errors_Detected
;
27341 No_Constit
: Boolean;
27343 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
27346 -- Do not analyze the pragma multiple times
27348 if Is_Analyzed_Pragma
(N
) then
27352 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
27354 -- Use the anonymous object as the proper spec when Refined_Global
27355 -- applies to the body of a single task type. The object carries the
27356 -- proper Chars as well as all non-refined versions of pragmas.
27358 if Is_Single_Concurrent_Type
(Spec_Id
) then
27359 Spec_Id
:= Anonymous_Object
(Spec_Id
);
27362 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27363 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
27365 -- The subprogram declaration lacks pragma Global. This renders
27366 -- Refined_Global useless as there is nothing to refine.
27368 if No
(Global
) then
27370 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
27371 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
27375 -- Extract all relevant items from the corresponding Global pragma
27377 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27379 -- Package and subprogram bodies are instantiated individually in
27380 -- a separate compiler pass. Due to this mode of instantiation, the
27381 -- refinement of a state may no longer be visible when a subprogram
27382 -- body contract is instantiated. Since the generic template is legal,
27383 -- do not perform this check in the instance to circumvent this oddity.
27385 if Is_Generic_Instance
(Spec_Id
) then
27388 -- Non-instance case
27391 -- The corresponding Global pragma must mention at least one
27392 -- state with a visible refinement at the point Refined_Global
27393 -- is processed. States with null refinements need Refined_Global
27394 -- pragma (SPARK RM 7.2.4(2)).
27396 if not Has_In_State
27397 and then not Has_In_Out_State
27398 and then not Has_Out_State
27399 and then not Has_Proof_In_State
27400 and then not Has_Null_State
27403 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
27404 & "depend on abstract state with visible refinement"),
27408 -- The global refinement of inputs and outputs cannot be null when
27409 -- the corresponding Global pragma contains at least one item except
27410 -- in the case where we have states with null refinements.
27412 elsif Nkind
(Items
) = N_Null
27414 (Present
(In_Items
)
27415 or else Present
(In_Out_Items
)
27416 or else Present
(Out_Items
)
27417 or else Present
(Proof_In_Items
))
27418 and then not Has_Null_State
27421 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
27422 & "global items"), N
, Spec_Id
);
27427 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
27428 -- This ensures that the categorization of all refined global items is
27429 -- consistent with their role.
27431 Analyze_Global_In_Decl_Part
(N
);
27433 -- Perform all refinement checks with respect to completeness and mode
27436 if Serious_Errors_Detected
= Errors
then
27437 Check_Refined_Global_List
(Items
);
27440 -- Store the information that no constituent is used in the global
27441 -- refinement, prior to calling checking procedures which remove items
27442 -- from the list of constituents.
27446 and then No
(In_Out_Constits
)
27447 and then No
(Out_Constits
)
27448 and then No
(Proof_In_Constits
);
27450 -- For Input states with visible refinement, at least one constituent
27451 -- must be used as an Input in the global refinement.
27453 if Serious_Errors_Detected
= Errors
then
27454 Check_Input_States
;
27457 -- Verify all possible completion variants for In_Out states with
27458 -- visible refinement.
27460 if Serious_Errors_Detected
= Errors
then
27461 Check_In_Out_States
;
27464 -- For Output states with visible refinement, all constituents must be
27465 -- used as Outputs in the global refinement.
27467 if Serious_Errors_Detected
= Errors
then
27468 Check_Output_States
;
27471 -- For Proof_In states with visible refinement, at least one constituent
27472 -- must be used as Proof_In in the global refinement.
27474 if Serious_Errors_Detected
= Errors
then
27475 Check_Proof_In_States
;
27478 -- Emit errors for all constituents that belong to other states with
27479 -- visible refinement that do not appear in Global.
27481 if Serious_Errors_Detected
= Errors
then
27482 Report_Extra_Constituents
;
27485 -- Emit errors for all items in Global that are not repeated in the
27486 -- global refinement and for which there is no full visible refinement
27487 -- and, in the case of states with partial visible refinement, no
27488 -- constituent is mentioned in the global refinement.
27490 if Serious_Errors_Detected
= Errors
then
27491 Report_Missing_Items
;
27494 -- Emit an error if no constituent is used in the global refinement
27495 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27496 -- one may be issued by the checking procedures. Do not perform this
27497 -- check in an instance because it was already performed successfully
27498 -- in the generic template.
27500 if Serious_Errors_Detected
= Errors
27501 and then not Is_Generic_Instance
(Spec_Id
)
27502 and then not Has_Null_State
27503 and then No_Constit
27505 SPARK_Msg_N
("missing refinement", N
);
27509 Set_Is_Analyzed_Pragma
(N
);
27510 end Analyze_Refined_Global_In_Decl_Part
;
27512 ----------------------------------------
27513 -- Analyze_Refined_State_In_Decl_Part --
27514 ----------------------------------------
27516 procedure Analyze_Refined_State_In_Decl_Part
27518 Freeze_Id
: Entity_Id
:= Empty
)
27520 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
27521 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27522 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
27524 Available_States
: Elist_Id
:= No_Elist
;
27525 -- A list of all abstract states defined in the package declaration that
27526 -- are available for refinement. The list is used to report unrefined
27529 Body_States
: Elist_Id
:= No_Elist
;
27530 -- A list of all hidden states that appear in the body of the related
27531 -- package. The list is used to report unused hidden states.
27533 Constituents_Seen
: Elist_Id
:= No_Elist
;
27534 -- A list that contains all constituents processed so far. The list is
27535 -- used to detect multiple uses of the same constituent.
27537 Freeze_Posted
: Boolean := False;
27538 -- A flag that controls the output of a freezing-related error (see use
27541 Refined_States_Seen
: Elist_Id
:= No_Elist
;
27542 -- A list that contains all refined states processed so far. The list is
27543 -- used to detect duplicate refinements.
27545 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
27546 -- Perform full analysis of a single refinement clause
27548 procedure Report_Unrefined_States
(States
: Elist_Id
);
27549 -- Emit errors for all unrefined abstract states found in list States
27551 -------------------------------
27552 -- Analyze_Refinement_Clause --
27553 -------------------------------
27555 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
27556 AR_Constit
: Entity_Id
:= Empty
;
27557 AW_Constit
: Entity_Id
:= Empty
;
27558 ER_Constit
: Entity_Id
:= Empty
;
27559 EW_Constit
: Entity_Id
:= Empty
;
27560 -- The entities of external constituents that contain one of the
27561 -- following enabled properties: Async_Readers, Async_Writers,
27562 -- Effective_Reads and Effective_Writes.
27564 External_Constit_Seen
: Boolean := False;
27565 -- Flag used to mark when at least one external constituent is part
27566 -- of the state refinement.
27568 Non_Null_Seen
: Boolean := False;
27569 Null_Seen
: Boolean := False;
27570 -- Flags used to detect multiple uses of null in a single clause or a
27571 -- mixture of null and non-null constituents.
27573 Part_Of_Constits
: Elist_Id
:= No_Elist
;
27574 -- A list of all candidate constituents subject to indicator Part_Of
27575 -- where the encapsulating state is the current state.
27578 State_Id
: Entity_Id
;
27579 -- The current state being refined
27581 procedure Analyze_Constituent
(Constit
: Node_Id
);
27582 -- Perform full analysis of a single constituent
27584 procedure Check_External_Property
27585 (Prop_Nam
: Name_Id
;
27587 Constit
: Entity_Id
);
27588 -- Determine whether a property denoted by name Prop_Nam is present
27589 -- in the refined state. Emit an error if this is not the case. Flag
27590 -- Enabled should be set when the property applies to the refined
27591 -- state. Constit denotes the constituent (if any) which introduces
27592 -- the property in the refinement.
27594 procedure Match_State
;
27595 -- Determine whether the state being refined appears in list
27596 -- Available_States. Emit an error when attempting to re-refine the
27597 -- state or when the state is not defined in the package declaration,
27598 -- otherwise remove the state from Available_States.
27600 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
27601 -- Emit errors for all unused Part_Of constituents in list Constits
27603 -------------------------
27604 -- Analyze_Constituent --
27605 -------------------------
27607 procedure Analyze_Constituent
(Constit
: Node_Id
) is
27608 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
27609 -- Determine whether constituent Constit denoted by its entity
27610 -- Constit_Id appears in Body_States. Emit an error when the
27611 -- constituent is not a valid hidden state of the related package
27612 -- or when it is used more than once. Otherwise remove the
27613 -- constituent from Body_States.
27615 -----------------------
27616 -- Match_Constituent --
27617 -----------------------
27619 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
27620 procedure Collect_Constituent
;
27621 -- Verify the legality of constituent Constit_Id and add it to
27622 -- the refinements of State_Id.
27624 -------------------------
27625 -- Collect_Constituent --
27626 -------------------------
27628 procedure Collect_Constituent
is
27629 Constits
: Elist_Id
;
27632 -- The Ghost policy in effect at the point of abstract state
27633 -- declaration and constituent must match (SPARK RM 6.9(15))
27635 Check_Ghost_Refinement
27636 (State
, State_Id
, Constit
, Constit_Id
);
27638 -- A synchronized state must be refined by a synchronized
27639 -- object or another synchronized state (SPARK RM 9.6).
27641 if Is_Synchronized_State
(State_Id
)
27642 and then not Is_Synchronized_Object
(Constit_Id
)
27643 and then not Is_Synchronized_State
(Constit_Id
)
27646 ("constituent of synchronized state & must be "
27647 & "synchronized", Constit
, State_Id
);
27650 -- Add the constituent to the list of processed items to aid
27651 -- with the detection of duplicates.
27653 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
27655 -- Collect the constituent in the list of refinement items
27656 -- and establish a relation between the refined state and
27659 Constits
:= Refinement_Constituents
(State_Id
);
27661 if No
(Constits
) then
27662 Constits
:= New_Elmt_List
;
27663 Set_Refinement_Constituents
(State_Id
, Constits
);
27666 Append_Elmt
(Constit_Id
, Constits
);
27667 Set_Encapsulating_State
(Constit_Id
, State_Id
);
27669 -- The state has at least one legal constituent, mark the
27670 -- start of the refinement region. The region ends when the
27671 -- body declarations end (see routine Analyze_Declarations).
27673 Set_Has_Visible_Refinement
(State_Id
);
27675 -- When the constituent is external, save its relevant
27676 -- property for further checks.
27678 if Async_Readers_Enabled
(Constit_Id
) then
27679 AR_Constit
:= Constit_Id
;
27680 External_Constit_Seen
:= True;
27683 if Async_Writers_Enabled
(Constit_Id
) then
27684 AW_Constit
:= Constit_Id
;
27685 External_Constit_Seen
:= True;
27688 if Effective_Reads_Enabled
(Constit_Id
) then
27689 ER_Constit
:= Constit_Id
;
27690 External_Constit_Seen
:= True;
27693 if Effective_Writes_Enabled
(Constit_Id
) then
27694 EW_Constit
:= Constit_Id
;
27695 External_Constit_Seen
:= True;
27697 end Collect_Constituent
;
27701 State_Elmt
: Elmt_Id
;
27703 -- Start of processing for Match_Constituent
27706 -- Detect a duplicate use of a constituent
27708 if Contains
(Constituents_Seen
, Constit_Id
) then
27710 ("duplicate use of constituent &", Constit
, Constit_Id
);
27714 -- The constituent is subject to a Part_Of indicator
27716 if Present
(Encapsulating_State
(Constit_Id
)) then
27717 if Encapsulating_State
(Constit_Id
) = State_Id
then
27718 Remove
(Part_Of_Constits
, Constit_Id
);
27719 Collect_Constituent
;
27721 -- The constituent is part of another state and is used
27722 -- incorrectly in the refinement of the current state.
27725 Error_Msg_Name_1
:= Chars
(State_Id
);
27727 ("& cannot act as constituent of state %",
27728 Constit
, Constit_Id
);
27730 ("\Part_Of indicator specifies encapsulator &",
27731 Constit
, Encapsulating_State
(Constit_Id
));
27734 -- The only other source of legal constituents is the body
27735 -- state space of the related package.
27738 if Present
(Body_States
) then
27739 State_Elmt
:= First_Elmt
(Body_States
);
27740 while Present
(State_Elmt
) loop
27742 -- Consume a valid constituent to signal that it has
27743 -- been encountered.
27745 if Node
(State_Elmt
) = Constit_Id
then
27746 Remove_Elmt
(Body_States
, State_Elmt
);
27747 Collect_Constituent
;
27751 Next_Elmt
(State_Elmt
);
27755 -- At this point it is known that the constituent is not
27756 -- part of the package hidden state and cannot be used in
27757 -- a refinement (SPARK RM 7.2.2(9)).
27759 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27761 ("cannot use & in refinement, constituent is not a hidden "
27762 & "state of package %", Constit
, Constit_Id
);
27764 end Match_Constituent
;
27768 Constit_Id
: Entity_Id
;
27769 Constits
: Elist_Id
;
27771 -- Start of processing for Analyze_Constituent
27774 -- Detect multiple uses of null in a single refinement clause or a
27775 -- mixture of null and non-null constituents.
27777 if Nkind
(Constit
) = N_Null
then
27780 ("multiple null constituents not allowed", Constit
);
27782 elsif Non_Null_Seen
then
27784 ("cannot mix null and non-null constituents", Constit
);
27789 -- Collect the constituent in the list of refinement items
27791 Constits
:= Refinement_Constituents
(State_Id
);
27793 if No
(Constits
) then
27794 Constits
:= New_Elmt_List
;
27795 Set_Refinement_Constituents
(State_Id
, Constits
);
27798 Append_Elmt
(Constit
, Constits
);
27800 -- The state has at least one legal constituent, mark the
27801 -- start of the refinement region. The region ends when the
27802 -- body declarations end (see Analyze_Declarations).
27804 Set_Has_Visible_Refinement
(State_Id
);
27807 -- Non-null constituents
27810 Non_Null_Seen
:= True;
27814 ("cannot mix null and non-null constituents", Constit
);
27818 Resolve_State
(Constit
);
27820 -- Ensure that the constituent denotes a valid state or a
27821 -- whole object (SPARK RM 7.2.2(5)).
27823 if Is_Entity_Name
(Constit
) then
27824 Constit_Id
:= Entity_Of
(Constit
);
27826 -- When a constituent is declared after a subprogram body
27827 -- that caused freezing of the related contract where
27828 -- pragma Refined_State resides, the constituent appears
27829 -- undefined and carries Any_Id as its entity.
27831 -- package body Pack
27832 -- with Refined_State => (State => Constit)
27835 -- with Refined_Global => (Input => Constit)
27843 if Constit_Id
= Any_Id
then
27844 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
27846 -- Emit a specialized info message when the contract of
27847 -- the related package body was "frozen" by another body.
27848 -- Note that it is not possible to precisely identify why
27849 -- the constituent is undefined because it is not visible
27850 -- when pragma Refined_State is analyzed. This message is
27851 -- a reasonable approximation.
27853 if Present
(Freeze_Id
) and then not Freeze_Posted
then
27854 Freeze_Posted
:= True;
27856 Error_Msg_Name_1
:= Chars
(Body_Id
);
27857 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27859 ("body & declared # freezes the contract of %",
27862 ("\all constituents must be declared before body #",
27865 -- A misplaced constituent is a critical error because
27866 -- pragma Refined_Depends or Refined_Global depends on
27867 -- the proper link between a state and a constituent.
27868 -- Stop the compilation, as this leads to a multitude
27869 -- of misleading cascaded errors.
27871 raise Unrecoverable_Error
;
27874 -- The constituent is a valid state or object
27876 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
27880 Match_Constituent
(Constit_Id
);
27882 -- The variable may eventually become a constituent of a
27883 -- single protected/task type. Record the reference now
27884 -- and verify its legality when analyzing the contract of
27885 -- the variable (SPARK RM 9.3).
27887 if Ekind
(Constit_Id
) = E_Variable
then
27888 Record_Possible_Part_Of_Reference
27889 (Var_Id
=> Constit_Id
,
27893 -- Otherwise the constituent is illegal
27897 ("constituent & must denote object or state",
27898 Constit
, Constit_Id
);
27901 -- The constituent is illegal
27904 SPARK_Msg_N
("malformed constituent", Constit
);
27907 end Analyze_Constituent
;
27909 -----------------------------
27910 -- Check_External_Property --
27911 -----------------------------
27913 procedure Check_External_Property
27914 (Prop_Nam
: Name_Id
;
27916 Constit
: Entity_Id
)
27919 -- The property is missing in the declaration of the state, but
27920 -- a constituent is introducing it in the state refinement
27921 -- (SPARK RM 7.2.8(2)).
27923 if not Enabled
and then Present
(Constit
) then
27924 Error_Msg_Name_1
:= Prop_Nam
;
27925 Error_Msg_Name_2
:= Chars
(State_Id
);
27927 ("constituent & introduces external property % in refinement "
27928 & "of state %", State
, Constit
);
27930 Error_Msg_Sloc
:= Sloc
(State_Id
);
27932 ("\property is missing in abstract state declaration #",
27935 end Check_External_Property
;
27941 procedure Match_State
is
27942 State_Elmt
: Elmt_Id
;
27945 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27947 if Contains
(Refined_States_Seen
, State_Id
) then
27949 ("duplicate refinement of state &", State
, State_Id
);
27953 -- Inspect the abstract states defined in the package declaration
27954 -- looking for a match.
27956 State_Elmt
:= First_Elmt
(Available_States
);
27957 while Present
(State_Elmt
) loop
27959 -- A valid abstract state is being refined in the body. Add
27960 -- the state to the list of processed refined states to aid
27961 -- with the detection of duplicate refinements. Remove the
27962 -- state from Available_States to signal that it has already
27965 if Node
(State_Elmt
) = State_Id
then
27966 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
27967 Remove_Elmt
(Available_States
, State_Elmt
);
27971 Next_Elmt
(State_Elmt
);
27974 -- If we get here, we are refining a state that is not defined in
27975 -- the package declaration.
27977 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27979 ("cannot refine state, & is not defined in package %",
27983 --------------------------------
27984 -- Report_Unused_Constituents --
27985 --------------------------------
27987 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27988 Constit_Elmt
: Elmt_Id
;
27989 Constit_Id
: Entity_Id
;
27990 Posted
: Boolean := False;
27993 if Present
(Constits
) then
27994 Constit_Elmt
:= First_Elmt
(Constits
);
27995 while Present
(Constit_Elmt
) loop
27996 Constit_Id
:= Node
(Constit_Elmt
);
27998 -- Generate an error message of the form:
28000 -- state ... has unused Part_Of constituents
28001 -- abstract state ... defined at ...
28002 -- constant ... defined at ...
28003 -- variable ... defined at ...
28008 ("state & has unused Part_Of constituents",
28012 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
28014 if Ekind
(Constit_Id
) = E_Abstract_State
then
28016 ("\abstract state & defined #", State
, Constit_Id
);
28018 elsif Ekind
(Constit_Id
) = E_Constant
then
28020 ("\constant & defined #", State
, Constit_Id
);
28023 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
28024 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
28027 Next_Elmt
(Constit_Elmt
);
28030 end Report_Unused_Constituents
;
28032 -- Local declarations
28034 Body_Ref
: Node_Id
;
28035 Body_Ref_Elmt
: Elmt_Id
;
28037 Extra_State
: Node_Id
;
28039 -- Start of processing for Analyze_Refinement_Clause
28042 -- A refinement clause appears as a component association where the
28043 -- sole choice is the state and the expressions are the constituents.
28044 -- This is a syntax error, always report.
28046 if Nkind
(Clause
) /= N_Component_Association
then
28047 Error_Msg_N
("malformed state refinement clause", Clause
);
28051 -- Analyze the state name of a refinement clause
28053 State
:= First
(Choices
(Clause
));
28056 Resolve_State
(State
);
28058 -- Ensure that the state name denotes a valid abstract state that is
28059 -- defined in the spec of the related package.
28061 if Is_Entity_Name
(State
) then
28062 State_Id
:= Entity_Of
(State
);
28064 -- When the abstract state is undefined, it appears as Any_Id. Do
28065 -- not continue with the analysis of the clause.
28067 if State_Id
= Any_Id
then
28070 -- Catch any attempts to re-refine a state or refine a state that
28071 -- is not defined in the package declaration.
28073 elsif Ekind
(State_Id
) = E_Abstract_State
then
28077 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
28081 -- References to a state with visible refinement are illegal.
28082 -- When nested packages are involved, detecting such references is
28083 -- tricky because pragma Refined_State is analyzed later than the
28084 -- offending pragma Depends or Global. References that occur in
28085 -- such nested context are stored in a list. Emit errors for all
28086 -- references found in Body_References (SPARK RM 6.1.4(8)).
28088 if Present
(Body_References
(State_Id
)) then
28089 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
28090 while Present
(Body_Ref_Elmt
) loop
28091 Body_Ref
:= Node
(Body_Ref_Elmt
);
28093 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
28094 Error_Msg_Sloc
:= Sloc
(State
);
28095 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
28097 Next_Elmt
(Body_Ref_Elmt
);
28101 -- The state name is illegal. This is a syntax error, always report.
28104 Error_Msg_N
("malformed state name in refinement clause", State
);
28108 -- A refinement clause may only refine one state at a time
28110 Extra_State
:= Next
(State
);
28112 if Present
(Extra_State
) then
28114 ("refinement clause cannot cover multiple states", Extra_State
);
28117 -- Replicate the Part_Of constituents of the refined state because
28118 -- the algorithm will consume items.
28120 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
28122 -- Analyze all constituents of the refinement. Multiple constituents
28123 -- appear as an aggregate.
28125 Constit
:= Expression
(Clause
);
28127 if Nkind
(Constit
) = N_Aggregate
then
28128 if Present
(Component_Associations
(Constit
)) then
28130 ("constituents of refinement clause must appear in "
28131 & "positional form", Constit
);
28133 else pragma Assert
(Present
(Expressions
(Constit
)));
28134 Constit
:= First
(Expressions
(Constit
));
28135 while Present
(Constit
) loop
28136 Analyze_Constituent
(Constit
);
28141 -- Various forms of a single constituent. Note that these may include
28142 -- malformed constituents.
28145 Analyze_Constituent
(Constit
);
28148 -- Verify that external constituents do not introduce new external
28149 -- property in the state refinement (SPARK RM 7.2.8(2)).
28151 if Is_External_State
(State_Id
) then
28152 Check_External_Property
28153 (Prop_Nam
=> Name_Async_Readers
,
28154 Enabled
=> Async_Readers_Enabled
(State_Id
),
28155 Constit
=> AR_Constit
);
28157 Check_External_Property
28158 (Prop_Nam
=> Name_Async_Writers
,
28159 Enabled
=> Async_Writers_Enabled
(State_Id
),
28160 Constit
=> AW_Constit
);
28162 Check_External_Property
28163 (Prop_Nam
=> Name_Effective_Reads
,
28164 Enabled
=> Effective_Reads_Enabled
(State_Id
),
28165 Constit
=> ER_Constit
);
28167 Check_External_Property
28168 (Prop_Nam
=> Name_Effective_Writes
,
28169 Enabled
=> Effective_Writes_Enabled
(State_Id
),
28170 Constit
=> EW_Constit
);
28172 -- When a refined state is not external, it should not have external
28173 -- constituents (SPARK RM 7.2.8(1)).
28175 elsif External_Constit_Seen
then
28177 ("non-external state & cannot contain external constituents in "
28178 & "refinement", State
, State_Id
);
28181 -- Ensure that all Part_Of candidate constituents have been mentioned
28182 -- in the refinement clause.
28184 Report_Unused_Constituents
(Part_Of_Constits
);
28185 end Analyze_Refinement_Clause
;
28187 -----------------------------
28188 -- Report_Unrefined_States --
28189 -----------------------------
28191 procedure Report_Unrefined_States
(States
: Elist_Id
) is
28192 State_Elmt
: Elmt_Id
;
28195 if Present
(States
) then
28196 State_Elmt
:= First_Elmt
(States
);
28197 while Present
(State_Elmt
) loop
28199 ("abstract state & must be refined", Node
(State_Elmt
));
28201 Next_Elmt
(State_Elmt
);
28204 end Report_Unrefined_States
;
28206 -- Local declarations
28208 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
28211 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28214 -- Do not analyze the pragma multiple times
28216 if Is_Analyzed_Pragma
(N
) then
28220 -- Save the scenario for examination by the ABE Processing phase
28222 Record_Elaboration_Scenario
(N
);
28224 -- Replicate the abstract states declared by the package because the
28225 -- matching algorithm will consume states.
28227 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
28229 -- Gather all abstract states and objects declared in the visible
28230 -- state space of the package body. These items must be utilized as
28231 -- constituents in a state refinement.
28233 Body_States
:= Collect_Body_States
(Body_Id
);
28235 -- Multiple non-null state refinements appear as an aggregate
28237 if Nkind
(Clauses
) = N_Aggregate
then
28238 if Present
(Expressions
(Clauses
)) then
28240 ("state refinements must appear as component associations",
28243 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
28244 Clause
:= First
(Component_Associations
(Clauses
));
28245 while Present
(Clause
) loop
28246 Analyze_Refinement_Clause
(Clause
);
28251 -- Various forms of a single state refinement. Note that these may
28252 -- include malformed refinements.
28255 Analyze_Refinement_Clause
(Clauses
);
28258 -- List all abstract states that were left unrefined
28260 Report_Unrefined_States
(Available_States
);
28262 Set_Is_Analyzed_Pragma
(N
);
28263 end Analyze_Refined_State_In_Decl_Part
;
28265 ------------------------------------
28266 -- Analyze_Test_Case_In_Decl_Part --
28267 ------------------------------------
28269 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
28270 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28271 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28273 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
28274 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28275 -- denoted by Arg_Nam.
28277 ------------------------------
28278 -- Preanalyze_Test_Case_Arg --
28279 ------------------------------
28281 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
28285 -- Preanalyze the original aspect argument for ASIS or for a generic
28286 -- subprogram to properly capture global references.
28288 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
28292 Arg_Nam
=> Arg_Nam
,
28293 From_Aspect
=> True);
28295 if Present
(Arg
) then
28296 Preanalyze_Assert_Expression
28297 (Expression
(Arg
), Standard_Boolean
);
28301 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
28303 if Present
(Arg
) then
28304 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
28306 end Preanalyze_Test_Case_Arg
;
28310 Restore_Scope
: Boolean := False;
28312 -- Start of processing for Analyze_Test_Case_In_Decl_Part
28315 -- Do not analyze the pragma multiple times
28317 if Is_Analyzed_Pragma
(N
) then
28321 -- Ensure that the formal parameters are visible when analyzing all
28322 -- clauses. This falls out of the general rule of aspects pertaining
28323 -- to subprogram declarations.
28325 if not In_Open_Scopes
(Spec_Id
) then
28326 Restore_Scope
:= True;
28327 Push_Scope
(Spec_Id
);
28329 if Is_Generic_Subprogram
(Spec_Id
) then
28330 Install_Generic_Formals
(Spec_Id
);
28332 Install_Formals
(Spec_Id
);
28336 Preanalyze_Test_Case_Arg
(Name_Requires
);
28337 Preanalyze_Test_Case_Arg
(Name_Ensures
);
28339 if Restore_Scope
then
28343 -- Currently it is not possible to inline pre/postconditions on a
28344 -- subprogram subject to pragma Inline_Always.
28346 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
28348 Set_Is_Analyzed_Pragma
(N
);
28349 end Analyze_Test_Case_In_Decl_Part
;
28355 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
28360 if Present
(List
) then
28361 Elmt
:= First_Elmt
(List
);
28362 while Present
(Elmt
) loop
28363 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
28366 Id
:= Entity_Of
(Node
(Elmt
));
28369 if Id
= Item_Id
then
28380 -----------------------------------
28381 -- Build_Pragma_Check_Equivalent --
28382 -----------------------------------
28384 function Build_Pragma_Check_Equivalent
28386 Subp_Id
: Entity_Id
:= Empty
;
28387 Inher_Id
: Entity_Id
:= Empty
;
28388 Keep_Pragma_Id
: Boolean := False) return Node_Id
28390 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
28391 -- Detect whether node N references a formal parameter subject to
28392 -- pragma Unreferenced. If this is the case, set Comes_From_Source
28393 -- to False to suppress the generation of a reference when analyzing
28396 ------------------------
28397 -- Suppress_Reference --
28398 ------------------------
28400 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
28401 Formal
: Entity_Id
;
28404 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28405 Formal
:= Entity
(N
);
28407 -- The formal parameter is subject to pragma Unreferenced. Prevent
28408 -- the generation of references by resetting the Comes_From_Source
28411 if Is_Formal
(Formal
)
28412 and then Has_Pragma_Unreferenced
(Formal
)
28414 Set_Comes_From_Source
(N
, False);
28419 end Suppress_Reference
;
28421 procedure Suppress_References
is
28422 new Traverse_Proc
(Suppress_Reference
);
28426 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
28427 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28428 Check_Prag
: Node_Id
;
28432 Needs_Wrapper
: Boolean;
28433 pragma Unreferenced
(Needs_Wrapper
);
28435 -- Start of processing for Build_Pragma_Check_Equivalent
28438 -- When the pre- or postcondition is inherited, map the formals of the
28439 -- inherited subprogram to those of the current subprogram. In addition,
28440 -- map primitive operations of the parent type into the corresponding
28441 -- primitive operations of the descendant.
28443 if Present
(Inher_Id
) then
28444 pragma Assert
(Present
(Subp_Id
));
28446 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
28448 -- Use generic machinery to copy inherited pragma, as if it were an
28449 -- instantiation, resetting source locations appropriately, so that
28450 -- expressions inside the inherited pragma use chained locations.
28451 -- This is used in particular in GNATprove to locate precisely
28452 -- messages on a given inherited pragma.
28454 Set_Copied_Sloc_For_Inherited_Pragma
28455 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
28456 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28458 -- Build the inherited class-wide condition
28460 Build_Class_Wide_Expression
28461 (Prag
=> Check_Prag
,
28463 Par_Subp
=> Inher_Id
,
28464 Adjust_Sloc
=> True,
28465 Needs_Wrapper
=> Needs_Wrapper
);
28467 -- If not an inherited condition simply copy the original pragma
28470 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28473 -- Mark the pragma as being internally generated and reset the Analyzed
28476 Set_Analyzed
(Check_Prag
, False);
28477 Set_Comes_From_Source
(Check_Prag
, False);
28479 -- The tree of the original pragma may contain references to the
28480 -- formal parameters of the related subprogram. At the same time
28481 -- the corresponding body may mark the formals as unreferenced:
28483 -- procedure Proc (Formal : ...)
28484 -- with Pre => Formal ...;
28486 -- procedure Proc (Formal : ...) is
28487 -- pragma Unreferenced (Formal);
28490 -- This creates problems because all pragma Check equivalents are
28491 -- analyzed at the end of the body declarations. Since all source
28492 -- references have already been accounted for, reset any references
28493 -- to such formals in the generated pragma Check equivalent.
28495 Suppress_References
(Check_Prag
);
28497 if Present
(Corresponding_Aspect
(Prag
)) then
28498 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
28503 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28504 -- the copied pragma in the newly created pragma, convert the copy into
28505 -- pragma Check by correcting the name and adding a check_kind argument.
28507 if not Keep_Pragma_Id
then
28508 Set_Class_Present
(Check_Prag
, False);
28510 Set_Pragma_Identifier
28511 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
28513 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
28514 Make_Pragma_Argument_Association
(Loc
,
28515 Expression
=> Make_Identifier
(Loc
, Nam
)));
28518 -- Update the error message when the pragma is inherited
28520 if Present
(Inher_Id
) then
28521 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
28523 if Chars
(Msg_Arg
) = Name_Message
then
28524 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
28526 -- Insert "inherited" to improve the error message
28528 if Name_Buffer
(1 .. 8) = "failed p" then
28529 Insert_Str_In_Name_Buffer
("inherited ", 8);
28530 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
28536 end Build_Pragma_Check_Equivalent
;
28538 -----------------------------
28539 -- Check_Applicable_Policy --
28540 -----------------------------
28542 procedure Check_Applicable_Policy
(N
: Node_Id
) is
28546 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
28549 -- No effect if not valid assertion kind name
28551 if not Is_Valid_Assertion_Kind
(Ename
) then
28555 -- Loop through entries in check policy list
28557 PP
:= Opt
.Check_Policy_List
;
28558 while Present
(PP
) loop
28560 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28561 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28565 or else Pnm
= Name_Assertion
28566 or else (Pnm
= Name_Statement_Assertions
28567 and then Nam_In
(Ename
, Name_Assert
,
28568 Name_Assert_And_Cut
,
28570 Name_Loop_Invariant
,
28571 Name_Loop_Variant
))
28573 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
28579 -- In CodePeer mode and GNATprove mode, we need to
28580 -- consider all assertions, unless they are disabled.
28581 -- Force Is_Checked on ignored assertions, in particular
28582 -- because transformations of the AST may depend on
28583 -- assertions being checked (e.g. the translation of
28584 -- attribute 'Loop_Entry).
28586 if CodePeer_Mode
or GNATprove_Mode
then
28587 Set_Is_Checked
(N
, True);
28588 Set_Is_Ignored
(N
, False);
28590 Set_Is_Checked
(N
, False);
28591 Set_Is_Ignored
(N
, True);
28597 Set_Is_Checked
(N
, True);
28598 Set_Is_Ignored
(N
, False);
28600 when Name_Disable
=>
28601 Set_Is_Ignored
(N
, True);
28602 Set_Is_Checked
(N
, False);
28603 Set_Is_Disabled
(N
, True);
28605 -- That should be exhaustive, the null here is a defence
28606 -- against a malformed tree from previous errors.
28615 PP
:= Next_Pragma
(PP
);
28619 -- If there are no specific entries that matched, then we let the
28620 -- setting of assertions govern. Note that this provides the needed
28621 -- compatibility with the RM for the cases of assertion, invariant,
28622 -- precondition, predicate, and postcondition. Note also that
28623 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
28625 if Assertions_Enabled
then
28626 Set_Is_Checked
(N
, True);
28627 Set_Is_Ignored
(N
, False);
28629 Set_Is_Checked
(N
, False);
28630 Set_Is_Ignored
(N
, True);
28632 end Check_Applicable_Policy
;
28634 -------------------------------
28635 -- Check_External_Properties --
28636 -------------------------------
28638 procedure Check_External_Properties
28646 -- All properties enabled
28648 if AR
and AW
and ER
and EW
then
28651 -- Async_Readers + Effective_Writes
28652 -- Async_Readers + Async_Writers + Effective_Writes
28654 elsif AR
and EW
and not ER
then
28657 -- Async_Writers + Effective_Reads
28658 -- Async_Readers + Async_Writers + Effective_Reads
28660 elsif AW
and ER
and not EW
then
28663 -- Async_Readers + Async_Writers
28665 elsif AR
and AW
and not ER
and not EW
then
28670 elsif AR
and not AW
and not ER
and not EW
then
28675 elsif AW
and not AR
and not ER
and not EW
then
28680 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
28683 end Check_External_Properties
;
28689 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
28693 -- Loop through entries in check policy list
28695 PP
:= Opt
.Check_Policy_List
;
28696 while Present
(PP
) loop
28698 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28699 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28703 or else (Pnm
= Name_Assertion
28704 and then Is_Valid_Assertion_Kind
(Nam
))
28705 or else (Pnm
= Name_Statement_Assertions
28706 and then Nam_In
(Nam
, Name_Assert
,
28707 Name_Assert_And_Cut
,
28709 Name_Loop_Invariant
,
28710 Name_Loop_Variant
))
28712 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
28721 return Name_Ignore
;
28723 when Name_Disable
=>
28724 return Name_Disable
;
28727 raise Program_Error
;
28731 PP
:= Next_Pragma
(PP
);
28736 -- If there are no specific entries that matched, then we let the
28737 -- setting of assertions govern. Note that this provides the needed
28738 -- compatibility with the RM for the cases of assertion, invariant,
28739 -- precondition, predicate, and postcondition.
28741 if Assertions_Enabled
then
28744 return Name_Ignore
;
28748 ---------------------------
28749 -- Check_Missing_Part_Of --
28750 ---------------------------
28752 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
28753 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
28754 -- Determine whether a package denoted by Pack_Id declares at least one
28757 -----------------------
28758 -- Has_Visible_State --
28759 -----------------------
28761 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
28762 Item_Id
: Entity_Id
;
28765 -- Traverse the entity chain of the package trying to find at least
28766 -- one visible abstract state, variable or a package [instantiation]
28767 -- that declares a visible state.
28769 Item_Id
:= First_Entity
(Pack_Id
);
28770 while Present
(Item_Id
)
28771 and then not In_Private_Part
(Item_Id
)
28773 -- Do not consider internally generated items
28775 if not Comes_From_Source
(Item_Id
) then
28778 -- A visible state has been found
28780 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
28783 -- Recursively peek into nested packages and instantiations
28785 elsif Ekind
(Item_Id
) = E_Package
28786 and then Has_Visible_State
(Item_Id
)
28791 Next_Entity
(Item_Id
);
28795 end Has_Visible_State
;
28799 Pack_Id
: Entity_Id
;
28800 Placement
: State_Space_Kind
;
28802 -- Start of processing for Check_Missing_Part_Of
28805 -- Do not consider abstract states, variables or package instantiations
28806 -- coming from an instance as those always inherit the Part_Of indicator
28807 -- of the instance itself.
28809 if In_Instance
then
28812 -- Do not consider internally generated entities as these can never
28813 -- have a Part_Of indicator.
28815 elsif not Comes_From_Source
(Item_Id
) then
28818 -- Perform these checks only when SPARK_Mode is enabled as they will
28819 -- interfere with standard Ada rules and produce false positives.
28821 elsif SPARK_Mode
/= On
then
28824 -- Do not consider constants, because the compiler cannot accurately
28825 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
28826 -- act as a hidden state of a package.
28828 elsif Ekind
(Item_Id
) = E_Constant
then
28832 -- Find where the abstract state, variable or package instantiation
28833 -- lives with respect to the state space.
28835 Find_Placement_In_State_Space
28836 (Item_Id
=> Item_Id
,
28837 Placement
=> Placement
,
28838 Pack_Id
=> Pack_Id
);
28840 -- Items that appear in a non-package construct (subprogram, block, etc)
28841 -- do not require a Part_Of indicator because they can never act as a
28844 if Placement
= Not_In_Package
then
28847 -- An item declared in the body state space of a package always act as a
28848 -- constituent and does not need explicit Part_Of indicator.
28850 elsif Placement
= Body_State_Space
then
28853 -- In general an item declared in the visible state space of a package
28854 -- does not require a Part_Of indicator. The only exception is when the
28855 -- related package is a nongeneric private child unit, in which case
28856 -- Part_Of must denote a state in the parent unit or in one of its
28859 elsif Placement
= Visible_State_Space
then
28860 if Is_Child_Unit
(Pack_Id
)
28861 and then not Is_Generic_Unit
(Pack_Id
)
28862 and then Is_Private_Descendant
(Pack_Id
)
28864 -- A package instantiation does not need a Part_Of indicator when
28865 -- the related generic template has no visible state.
28867 if Ekind
(Item_Id
) = E_Package
28868 and then Is_Generic_Instance
(Item_Id
)
28869 and then not Has_Visible_State
(Item_Id
)
28873 -- All other cases require Part_Of
28877 ("indicator Part_Of is required in this context "
28878 & "(SPARK RM 7.2.6(3))", Item_Id
);
28879 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28881 ("\& is declared in the visible part of private child "
28882 & "unit %", Item_Id
);
28886 -- When the item appears in the private state space of a package, it
28887 -- must be a part of some state declared by the said package.
28889 else pragma Assert
(Placement
= Private_State_Space
);
28891 -- The related package does not declare a state, the item cannot act
28892 -- as a Part_Of constituent.
28894 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
28897 -- A package instantiation does not need a Part_Of indicator when the
28898 -- related generic template has no visible state.
28900 elsif Ekind
(Pack_Id
) = E_Package
28901 and then Is_Generic_Instance
(Pack_Id
)
28902 and then not Has_Visible_State
(Pack_Id
)
28906 -- All other cases require Part_Of
28910 ("indicator Part_Of is required in this context "
28911 & "(SPARK RM 7.2.6(2))", Item_Id
);
28912 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28914 ("\& is declared in the private part of package %", Item_Id
);
28917 end Check_Missing_Part_Of
;
28919 ---------------------------------------------------
28920 -- Check_Postcondition_Use_In_Inlined_Subprogram --
28921 ---------------------------------------------------
28923 procedure Check_Postcondition_Use_In_Inlined_Subprogram
28925 Spec_Id
: Entity_Id
)
28928 if Warn_On_Redundant_Constructs
28929 and then Has_Pragma_Inline_Always
(Spec_Id
)
28930 and then Assertions_Enabled
28932 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28934 if From_Aspect_Specification
(Prag
) then
28936 ("aspect % not enforced on inlined subprogram &?r?",
28937 Corresponding_Aspect
(Prag
), Spec_Id
);
28940 ("pragma % not enforced on inlined subprogram &?r?",
28944 end Check_Postcondition_Use_In_Inlined_Subprogram
;
28946 -------------------------------------
28947 -- Check_State_And_Constituent_Use --
28948 -------------------------------------
28950 procedure Check_State_And_Constituent_Use
28951 (States
: Elist_Id
;
28952 Constits
: Elist_Id
;
28955 Constit_Elmt
: Elmt_Id
;
28956 Constit_Id
: Entity_Id
;
28957 State_Id
: Entity_Id
;
28960 -- Nothing to do if there are no states or constituents
28962 if No
(States
) or else No
(Constits
) then
28966 -- Inspect the list of constituents and try to determine whether its
28967 -- encapsulating state is in list States.
28969 Constit_Elmt
:= First_Elmt
(Constits
);
28970 while Present
(Constit_Elmt
) loop
28971 Constit_Id
:= Node
(Constit_Elmt
);
28973 -- Determine whether the constituent is part of an encapsulating
28974 -- state that appears in the same context and if this is the case,
28975 -- emit an error (SPARK RM 7.2.6(7)).
28977 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
28979 if Present
(State_Id
) then
28980 Error_Msg_Name_1
:= Chars
(Constit_Id
);
28982 ("cannot mention state & and its constituent % in the same "
28983 & "context", Context
, State_Id
);
28987 Next_Elmt
(Constit_Elmt
);
28989 end Check_State_And_Constituent_Use
;
28991 ---------------------------------------------
28992 -- Collect_Inherited_Class_Wide_Conditions --
28993 ---------------------------------------------
28995 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28996 Parent_Subp
: constant Entity_Id
:=
28997 Ultimate_Alias
(Overridden_Operation
(Subp
));
28998 -- The Overridden_Operation may itself be inherited and as such have no
28999 -- explicit contract.
29001 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
29002 In_Spec_Expr
: Boolean;
29003 Installed
: Boolean;
29005 New_Prag
: Node_Id
;
29008 Installed
:= False;
29010 -- Iterate over the contract of the overridden subprogram to find all
29011 -- inherited class-wide pre- and postconditions.
29013 if Present
(Prags
) then
29014 Prag
:= Pre_Post_Conditions
(Prags
);
29016 while Present
(Prag
) loop
29017 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
29018 Name_Precondition
, Name_Postcondition
)
29019 and then Class_Present
(Prag
)
29021 -- The generated pragma must be analyzed in the context of
29022 -- the subprogram, to make its formals visible. In addition,
29023 -- we must inhibit freezing and full analysis because the
29024 -- controlling type of the subprogram is not frozen yet, and
29025 -- may have further primitives.
29027 if not Installed
then
29030 Install_Formals
(Subp
);
29031 In_Spec_Expr
:= In_Spec_Expression
;
29032 In_Spec_Expression
:= True;
29036 Build_Pragma_Check_Equivalent
29037 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
29039 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
29040 Preanalyze
(New_Prag
);
29042 -- Prevent further analysis in subsequent processing of the
29043 -- current list of declarations
29045 Set_Analyzed
(New_Prag
);
29048 Prag
:= Next_Pragma
(Prag
);
29052 In_Spec_Expression
:= In_Spec_Expr
;
29056 end Collect_Inherited_Class_Wide_Conditions
;
29058 ---------------------------------------
29059 -- Collect_Subprogram_Inputs_Outputs --
29060 ---------------------------------------
29062 procedure Collect_Subprogram_Inputs_Outputs
29063 (Subp_Id
: Entity_Id
;
29064 Synthesize
: Boolean := False;
29065 Subp_Inputs
: in out Elist_Id
;
29066 Subp_Outputs
: in out Elist_Id
;
29067 Global_Seen
: out Boolean)
29069 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
29070 -- Collect all relevant items from a dependency clause
29072 procedure Collect_Global_List
29074 Mode
: Name_Id
:= Name_Input
);
29075 -- Collect all relevant items from a global list
29077 -------------------------------
29078 -- Collect_Dependency_Clause --
29079 -------------------------------
29081 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
29082 procedure Collect_Dependency_Item
29084 Is_Input
: Boolean);
29085 -- Add an item to the proper subprogram input or output collection
29087 -----------------------------
29088 -- Collect_Dependency_Item --
29089 -----------------------------
29091 procedure Collect_Dependency_Item
29093 Is_Input
: Boolean)
29098 -- Nothing to collect when the item is null
29100 if Nkind
(Item
) = N_Null
then
29103 -- Ditto for attribute 'Result
29105 elsif Is_Attribute_Result
(Item
) then
29108 -- Multiple items appear as an aggregate
29110 elsif Nkind
(Item
) = N_Aggregate
then
29111 Extra
:= First
(Expressions
(Item
));
29112 while Present
(Extra
) loop
29113 Collect_Dependency_Item
(Extra
, Is_Input
);
29117 -- Otherwise this is a solitary item
29121 Append_New_Elmt
(Item
, Subp_Inputs
);
29123 Append_New_Elmt
(Item
, Subp_Outputs
);
29126 end Collect_Dependency_Item
;
29128 -- Start of processing for Collect_Dependency_Clause
29131 if Nkind
(Clause
) = N_Null
then
29134 -- A dependency clause appears as component association
29136 elsif Nkind
(Clause
) = N_Component_Association
then
29137 Collect_Dependency_Item
29138 (Item
=> Expression
(Clause
),
29141 Collect_Dependency_Item
29142 (Item
=> First
(Choices
(Clause
)),
29143 Is_Input
=> False);
29145 -- To accommodate partial decoration of disabled SPARK features, this
29146 -- routine may be called with illegal input. If this is the case, do
29147 -- not raise Program_Error.
29152 end Collect_Dependency_Clause
;
29154 -------------------------
29155 -- Collect_Global_List --
29156 -------------------------
29158 procedure Collect_Global_List
29160 Mode
: Name_Id
:= Name_Input
)
29162 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
29163 -- Add an item to the proper subprogram input or output collection
29165 -------------------------
29166 -- Collect_Global_Item --
29167 -------------------------
29169 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
29171 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
29172 Append_New_Elmt
(Item
, Subp_Inputs
);
29175 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
29176 Append_New_Elmt
(Item
, Subp_Outputs
);
29178 end Collect_Global_Item
;
29185 -- Start of processing for Collect_Global_List
29188 if Nkind
(List
) = N_Null
then
29191 -- Single global item declaration
29193 elsif Nkind_In
(List
, N_Expanded_Name
,
29195 N_Selected_Component
)
29197 Collect_Global_Item
(List
, Mode
);
29199 -- Simple global list or moded global list declaration
29201 elsif Nkind
(List
) = N_Aggregate
then
29202 if Present
(Expressions
(List
)) then
29203 Item
:= First
(Expressions
(List
));
29204 while Present
(Item
) loop
29205 Collect_Global_Item
(Item
, Mode
);
29210 Assoc
:= First
(Component_Associations
(List
));
29211 while Present
(Assoc
) loop
29212 Collect_Global_List
29213 (List
=> Expression
(Assoc
),
29214 Mode
=> Chars
(First
(Choices
(Assoc
))));
29219 -- To accommodate partial decoration of disabled SPARK features, this
29220 -- routine may be called with illegal input. If this is the case, do
29221 -- not raise Program_Error.
29226 end Collect_Global_List
;
29233 Formal
: Entity_Id
;
29235 Spec_Id
: Entity_Id
:= Empty
;
29236 Subp_Decl
: Node_Id
;
29239 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29242 Global_Seen
:= False;
29244 -- Process all formal parameters of entries, [generic] subprograms, and
29247 if Ekind_In
(Subp_Id
, E_Entry
,
29250 E_Generic_Function
,
29251 E_Generic_Procedure
,
29255 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
29256 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29258 -- Process all formal parameters
29260 Formal
:= First_Entity
(Spec_Id
);
29261 while Present
(Formal
) loop
29262 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
29263 Append_New_Elmt
(Formal
, Subp_Inputs
);
29266 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
29267 Append_New_Elmt
(Formal
, Subp_Outputs
);
29269 -- Out parameters can act as inputs when the related type is
29270 -- tagged, unconstrained array, unconstrained record, or record
29271 -- with unconstrained components.
29273 if Ekind
(Formal
) = E_Out_Parameter
29274 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
29276 Append_New_Elmt
(Formal
, Subp_Inputs
);
29280 Next_Entity
(Formal
);
29283 -- Otherwise the input denotes a task type, a task body, or the
29284 -- anonymous object created for a single task type.
29286 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
29287 or else Is_Single_Task_Object
(Subp_Id
)
29289 Subp_Decl
:= Declaration_Node
(Subp_Id
);
29290 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29293 -- When processing an entry, subprogram or task body, look for pragmas
29294 -- Refined_Depends and Refined_Global as they specify the inputs and
29297 if Is_Entry_Body
(Subp_Id
)
29298 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
29300 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
29301 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
29303 -- Subprogram declaration or stand-alone body case, look for pragmas
29304 -- Depends and Global
29307 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
29308 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
29311 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
29312 -- because it provides finer granularity of inputs and outputs.
29314 if Present
(Global
) then
29315 Global_Seen
:= True;
29316 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
29318 -- When the related subprogram lacks pragma [Refined_]Global, fall back
29319 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
29320 -- the inputs and outputs from [Refined_]Depends.
29322 elsif Synthesize
and then Present
(Depends
) then
29323 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
29325 -- Multiple dependency clauses appear as an aggregate
29327 if Nkind
(Clauses
) = N_Aggregate
then
29328 Clause
:= First
(Component_Associations
(Clauses
));
29329 while Present
(Clause
) loop
29330 Collect_Dependency_Clause
(Clause
);
29334 -- Otherwise this is a single dependency clause
29337 Collect_Dependency_Clause
(Clauses
);
29341 -- The current instance of a protected type acts as a formal parameter
29342 -- of mode IN for functions and IN OUT for entries and procedures
29343 -- (SPARK RM 6.1.4).
29345 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
29346 Typ
:= Scope
(Spec_Id
);
29348 -- Use the anonymous object when the type is single protected
29350 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
29351 Typ
:= Anonymous_Object
(Typ
);
29354 Append_New_Elmt
(Typ
, Subp_Inputs
);
29356 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
29357 Append_New_Elmt
(Typ
, Subp_Outputs
);
29360 -- The current instance of a task type acts as a formal parameter of
29361 -- mode IN OUT (SPARK RM 6.1.4).
29363 elsif Ekind
(Spec_Id
) = E_Task_Type
then
29366 -- Use the anonymous object when the type is single task
29368 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
29369 Typ
:= Anonymous_Object
(Typ
);
29372 Append_New_Elmt
(Typ
, Subp_Inputs
);
29373 Append_New_Elmt
(Typ
, Subp_Outputs
);
29375 elsif Is_Single_Task_Object
(Spec_Id
) then
29376 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
29377 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
29379 end Collect_Subprogram_Inputs_Outputs
;
29381 ---------------------------
29382 -- Contract_Freeze_Error --
29383 ---------------------------
29385 procedure Contract_Freeze_Error
29386 (Contract_Id
: Entity_Id
;
29387 Freeze_Id
: Entity_Id
)
29390 Error_Msg_Name_1
:= Chars
(Contract_Id
);
29391 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
29394 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
29396 ("\all contractual items must be declared before body #", Contract_Id
);
29397 end Contract_Freeze_Error
;
29399 ---------------------------------
29400 -- Delay_Config_Pragma_Analyze --
29401 ---------------------------------
29403 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
29405 return Nam_In
(Pragma_Name_Unmapped
(N
),
29406 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
29407 end Delay_Config_Pragma_Analyze
;
29409 -----------------------
29410 -- Duplication_Error --
29411 -----------------------
29413 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
29414 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
29415 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
29418 Error_Msg_Sloc
:= Sloc
(Prev
);
29419 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
29421 -- Emit a precise message to distinguish between source pragmas and
29422 -- pragmas generated from aspects. The ordering of the two pragmas is
29426 -- Prag -- duplicate
29428 -- No error is emitted when both pragmas come from aspects because this
29429 -- is already detected by the general aspect analysis mechanism.
29431 if Prag_From_Asp
and Prev_From_Asp
then
29433 elsif Prag_From_Asp
then
29434 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
29435 elsif Prev_From_Asp
then
29436 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
29438 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
29440 end Duplication_Error
;
29442 ------------------------------
29443 -- Find_Encapsulating_State --
29444 ------------------------------
29446 function Find_Encapsulating_State
29447 (States
: Elist_Id
;
29448 Constit_Id
: Entity_Id
) return Entity_Id
29450 State_Id
: Entity_Id
;
29453 -- Since a constituent may be part of a larger constituent set, climb
29454 -- the encapsulating state chain looking for a state that appears in
29457 State_Id
:= Encapsulating_State
(Constit_Id
);
29458 while Present
(State_Id
) loop
29459 if Contains
(States
, State_Id
) then
29463 State_Id
:= Encapsulating_State
(State_Id
);
29467 end Find_Encapsulating_State
;
29469 --------------------------
29470 -- Find_Related_Context --
29471 --------------------------
29473 function Find_Related_Context
29475 Do_Checks
: Boolean := False) return Node_Id
29480 Stmt
:= Prev
(Prag
);
29481 while Present
(Stmt
) loop
29483 -- Skip prior pragmas, but check for duplicates
29485 if Nkind
(Stmt
) = N_Pragma
then
29487 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
29494 -- Skip internally generated code
29496 elsif not Comes_From_Source
(Stmt
) then
29498 -- The anonymous object created for a single concurrent type is a
29499 -- suitable context.
29501 if Nkind
(Stmt
) = N_Object_Declaration
29502 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29507 -- Return the current source construct
29517 end Find_Related_Context
;
29519 --------------------------------------
29520 -- Find_Related_Declaration_Or_Body --
29521 --------------------------------------
29523 function Find_Related_Declaration_Or_Body
29525 Do_Checks
: Boolean := False) return Node_Id
29527 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
29529 procedure Expression_Function_Error
;
29530 -- Emit an error concerning pragma Prag that illegaly applies to an
29531 -- expression function.
29533 -------------------------------
29534 -- Expression_Function_Error --
29535 -------------------------------
29537 procedure Expression_Function_Error
is
29539 Error_Msg_Name_1
:= Prag_Nam
;
29541 -- Emit a precise message to distinguish between source pragmas and
29542 -- pragmas generated from aspects.
29544 if From_Aspect_Specification
(Prag
) then
29546 ("aspect % cannot apply to a stand alone expression function",
29550 ("pragma % cannot apply to a stand alone expression function",
29553 end Expression_Function_Error
;
29557 Context
: constant Node_Id
:= Parent
(Prag
);
29560 Look_For_Body
: constant Boolean :=
29561 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
29562 Name_Refined_Global
,
29564 Name_Refined_State
);
29565 -- Refinement pragmas must be associated with a subprogram body [stub]
29567 -- Start of processing for Find_Related_Declaration_Or_Body
29570 Stmt
:= Prev
(Prag
);
29571 while Present
(Stmt
) loop
29573 -- Skip prior pragmas, but check for duplicates. Pragmas produced
29574 -- by splitting a complex pre/postcondition are not considered to
29577 if Nkind
(Stmt
) = N_Pragma
then
29579 and then not Split_PPC
(Stmt
)
29580 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
29587 -- Emit an error when a refinement pragma appears on an expression
29588 -- function without a completion.
29591 and then Look_For_Body
29592 and then Nkind
(Stmt
) = N_Subprogram_Declaration
29593 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
29594 and then not Has_Completion
(Defining_Entity
(Stmt
))
29596 Expression_Function_Error
;
29599 -- The refinement pragma applies to a subprogram body stub
29601 elsif Look_For_Body
29602 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
29606 -- Skip internally generated code
29608 elsif not Comes_From_Source
(Stmt
) then
29610 -- The anonymous object created for a single concurrent type is a
29611 -- suitable context.
29613 if Nkind
(Stmt
) = N_Object_Declaration
29614 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29618 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
29620 -- The subprogram declaration is an internally generated spec
29621 -- for an expression function.
29623 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29626 -- The subprogram is actually an instance housed within an
29627 -- anonymous wrapper package.
29629 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29634 -- Return the current construct which is either a subprogram body,
29635 -- a subprogram declaration or is illegal.
29644 -- If we fall through, then the pragma was either the first declaration
29645 -- or it was preceded by other pragmas and no source constructs.
29647 -- The pragma is associated with a library-level subprogram
29649 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
29650 return Unit
(Parent
(Context
));
29652 -- The pragma appears inside the declarations of an entry body
29654 elsif Nkind
(Context
) = N_Entry_Body
then
29657 -- The pragma appears inside the statements of a subprogram body. This
29658 -- placement is the result of subprogram contract expansion.
29660 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
29661 return Parent
(Context
);
29663 -- The pragma appears inside the declarative part of a package body
29665 elsif Nkind
(Context
) = N_Package_Body
then
29668 -- The pragma appears inside the declarative part of a subprogram body
29670 elsif Nkind
(Context
) = N_Subprogram_Body
then
29673 -- The pragma appears inside the declarative part of a task body
29675 elsif Nkind
(Context
) = N_Task_Body
then
29678 -- The pragma appears inside the visible part of a package specification
29680 elsif Nkind
(Context
) = N_Package_Specification
then
29681 return Parent
(Context
);
29683 -- The pragma is a byproduct of aspect expansion, return the related
29684 -- context of the original aspect. This case has a lower priority as
29685 -- the above circuitry pinpoints precisely the related context.
29687 elsif Present
(Corresponding_Aspect
(Prag
)) then
29688 return Parent
(Corresponding_Aspect
(Prag
));
29690 -- No candidate subprogram [body] found
29695 end Find_Related_Declaration_Or_Body
;
29697 ----------------------------------
29698 -- Find_Related_Package_Or_Body --
29699 ----------------------------------
29701 function Find_Related_Package_Or_Body
29703 Do_Checks
: Boolean := False) return Node_Id
29705 Context
: constant Node_Id
:= Parent
(Prag
);
29706 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29710 Stmt
:= Prev
(Prag
);
29711 while Present
(Stmt
) loop
29713 -- Skip prior pragmas, but check for duplicates
29715 if Nkind
(Stmt
) = N_Pragma
then
29716 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
29722 -- Skip internally generated code
29724 elsif not Comes_From_Source
(Stmt
) then
29725 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
29727 -- The subprogram declaration is an internally generated spec
29728 -- for an expression function.
29730 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29733 -- The subprogram is actually an instance housed within an
29734 -- anonymous wrapper package.
29736 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29741 -- Return the current source construct which is illegal
29750 -- If we fall through, then the pragma was either the first declaration
29751 -- or it was preceded by other pragmas and no source constructs.
29753 -- The pragma is associated with a package. The immediate context in
29754 -- this case is the specification of the package.
29756 if Nkind
(Context
) = N_Package_Specification
then
29757 return Parent
(Context
);
29759 -- The pragma appears in the declarations of a package body
29761 elsif Nkind
(Context
) = N_Package_Body
then
29764 -- The pragma appears in the statements of a package body
29766 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
29767 and then Nkind
(Parent
(Context
)) = N_Package_Body
29769 return Parent
(Context
);
29771 -- The pragma is a byproduct of aspect expansion, return the related
29772 -- context of the original aspect. This case has a lower priority as
29773 -- the above circuitry pinpoints precisely the related context.
29775 elsif Present
(Corresponding_Aspect
(Prag
)) then
29776 return Parent
(Corresponding_Aspect
(Prag
));
29778 -- No candidate package [body] found
29783 end Find_Related_Package_Or_Body
;
29789 function Get_Argument
29791 Context_Id
: Entity_Id
:= Empty
) return Node_Id
29793 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
29796 -- Use the expression of the original aspect when compiling for ASIS or
29797 -- when analyzing the template of a generic unit. In both cases the
29798 -- aspect's tree must be decorated to allow for ASIS queries or to save
29799 -- the global references in the generic context.
29801 if From_Aspect_Specification
(Prag
)
29802 and then (ASIS_Mode
or else (Present
(Context_Id
)
29803 and then Is_Generic_Unit
(Context_Id
)))
29805 return Corresponding_Aspect
(Prag
);
29807 -- Otherwise use the expression of the pragma
29809 elsif Present
(Args
) then
29810 return First
(Args
);
29817 -------------------------
29818 -- Get_Base_Subprogram --
29819 -------------------------
29821 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
29823 -- Follow subprogram renaming chain
29825 if Is_Subprogram
(Def_Id
)
29826 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
29827 N_Subprogram_Renaming_Declaration
29828 and then Present
(Alias
(Def_Id
))
29830 return Alias
(Def_Id
);
29834 end Get_Base_Subprogram
;
29836 -----------------------
29837 -- Get_SPARK_Mode_Type --
29838 -----------------------
29840 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
29842 if N
= Name_On
then
29844 elsif N
= Name_Off
then
29847 -- Any other argument is illegal. Assume that no SPARK mode applies to
29848 -- avoid potential cascaded errors.
29853 end Get_SPARK_Mode_Type
;
29855 ------------------------------------
29856 -- Get_SPARK_Mode_From_Annotation --
29857 ------------------------------------
29859 function Get_SPARK_Mode_From_Annotation
29860 (N
: Node_Id
) return SPARK_Mode_Type
29865 if Nkind
(N
) = N_Aspect_Specification
then
29866 Mode
:= Expression
(N
);
29868 else pragma Assert
(Nkind
(N
) = N_Pragma
);
29869 Mode
:= First
(Pragma_Argument_Associations
(N
));
29871 if Present
(Mode
) then
29872 Mode
:= Get_Pragma_Arg
(Mode
);
29876 -- Aspect or pragma SPARK_Mode specifies an explicit mode
29878 if Present
(Mode
) then
29879 if Nkind
(Mode
) = N_Identifier
then
29880 return Get_SPARK_Mode_Type
(Chars
(Mode
));
29882 -- In case of a malformed aspect or pragma, return the default None
29888 -- Otherwise the lack of an expression defaults SPARK_Mode to On
29893 end Get_SPARK_Mode_From_Annotation
;
29895 ---------------------------
29896 -- Has_Extra_Parentheses --
29897 ---------------------------
29899 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
29903 -- The aggregate should not have an expression list because a clause
29904 -- is always interpreted as a component association. The only way an
29905 -- expression list can sneak in is by adding extra parentheses around
29906 -- the individual clauses:
29908 -- Depends (Output => Input) -- proper form
29909 -- Depends ((Output => Input)) -- extra parentheses
29911 -- Since the extra parentheses are not allowed by the syntax of the
29912 -- pragma, flag them now to avoid emitting misleading errors down the
29915 if Nkind
(Clause
) = N_Aggregate
29916 and then Present
(Expressions
(Clause
))
29918 Expr
:= First
(Expressions
(Clause
));
29919 while Present
(Expr
) loop
29921 -- A dependency clause surrounded by extra parentheses appears
29922 -- as an aggregate of component associations with an optional
29923 -- Paren_Count set.
29925 if Nkind
(Expr
) = N_Aggregate
29926 and then Present
(Component_Associations
(Expr
))
29929 ("dependency clause contains extra parentheses", Expr
);
29931 -- Otherwise the expression is a malformed construct
29934 SPARK_Msg_N
("malformed dependency clause", Expr
);
29944 end Has_Extra_Parentheses
;
29950 procedure Initialize
is
29961 Dummy
:= Dummy
+ 1;
29964 -----------------------------
29965 -- Is_Config_Static_String --
29966 -----------------------------
29968 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29970 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
29971 -- This is an internal recursive function that is just like the outer
29972 -- function except that it adds the string to the name buffer rather
29973 -- than placing the string in the name buffer.
29975 ------------------------------
29976 -- Add_Config_Static_String --
29977 ------------------------------
29979 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29986 if Nkind
(N
) = N_Op_Concat
then
29987 if Add_Config_Static_String
(Left_Opnd
(N
)) then
29988 N
:= Right_Opnd
(N
);
29994 if Nkind
(N
) /= N_String_Literal
then
29995 Error_Msg_N
("string literal expected for pragma argument", N
);
29999 for J
in 1 .. String_Length
(Strval
(N
)) loop
30000 C
:= Get_String_Char
(Strval
(N
), J
);
30002 if not In_Character_Range
(C
) then
30004 ("string literal contains invalid wide character",
30005 Sloc
(N
) + 1 + Source_Ptr
(J
));
30009 Add_Char_To_Name_Buffer
(Get_Character
(C
));
30014 end Add_Config_Static_String
;
30016 -- Start of processing for Is_Config_Static_String
30021 return Add_Config_Static_String
(Arg
);
30022 end Is_Config_Static_String
;
30024 -------------------------------
30025 -- Is_Elaboration_SPARK_Mode --
30026 -------------------------------
30028 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
30031 (Nkind
(N
) = N_Pragma
30032 and then Pragma_Name
(N
) = Name_SPARK_Mode
30033 and then Is_List_Member
(N
));
30035 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30036 -- appears in the statement part of the body.
30039 Present
(Parent
(N
))
30040 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
30041 and then List_Containing
(N
) = Statements
(Parent
(N
))
30042 and then Present
(Parent
(Parent
(N
)))
30043 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
30044 end Is_Elaboration_SPARK_Mode
;
30046 -----------------------
30047 -- Is_Enabled_Pragma --
30048 -----------------------
30050 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
30054 if Present
(Prag
) then
30055 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30057 if Present
(Arg
) then
30058 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
30060 -- The lack of a Boolean argument automatically enables the pragma
30066 -- The pragma is missing, therefore it is not enabled
30071 end Is_Enabled_Pragma
;
30073 -----------------------------------------
30074 -- Is_Non_Significant_Pragma_Reference --
30075 -----------------------------------------
30077 -- This function makes use of the following static table which indicates
30078 -- whether appearance of some name in a given pragma is to be considered
30079 -- as a reference for the purposes of warnings about unreferenced objects.
30081 -- -1 indicates that appearence in any argument is significant
30082 -- 0 indicates that appearance in any argument is not significant
30083 -- +n indicates that appearance as argument n is significant, but all
30084 -- other arguments are not significant
30085 -- 9n arguments from n on are significant, before n insignificant
30087 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
30088 (Pragma_Abort_Defer
=> -1,
30089 Pragma_Abstract_State
=> -1,
30090 Pragma_Ada_83
=> -1,
30091 Pragma_Ada_95
=> -1,
30092 Pragma_Ada_05
=> -1,
30093 Pragma_Ada_2005
=> -1,
30094 Pragma_Ada_12
=> -1,
30095 Pragma_Ada_2012
=> -1,
30096 Pragma_Ada_2020
=> -1,
30097 Pragma_All_Calls_Remote
=> -1,
30098 Pragma_Allow_Integer_Address
=> -1,
30099 Pragma_Annotate
=> 93,
30100 Pragma_Assert
=> -1,
30101 Pragma_Assert_And_Cut
=> -1,
30102 Pragma_Assertion_Policy
=> 0,
30103 Pragma_Assume
=> -1,
30104 Pragma_Assume_No_Invalid_Values
=> 0,
30105 Pragma_Async_Readers
=> 0,
30106 Pragma_Async_Writers
=> 0,
30107 Pragma_Asynchronous
=> 0,
30108 Pragma_Atomic
=> 0,
30109 Pragma_Atomic_Components
=> 0,
30110 Pragma_Attach_Handler
=> -1,
30111 Pragma_Attribute_Definition
=> 92,
30112 Pragma_Check
=> -1,
30113 Pragma_Check_Float_Overflow
=> 0,
30114 Pragma_Check_Name
=> 0,
30115 Pragma_Check_Policy
=> 0,
30116 Pragma_CPP_Class
=> 0,
30117 Pragma_CPP_Constructor
=> 0,
30118 Pragma_CPP_Virtual
=> 0,
30119 Pragma_CPP_Vtable
=> 0,
30121 Pragma_C_Pass_By_Copy
=> 0,
30122 Pragma_Comment
=> -1,
30123 Pragma_Common_Object
=> 0,
30124 Pragma_Compile_Time_Error
=> -1,
30125 Pragma_Compile_Time_Warning
=> -1,
30126 Pragma_Compiler_Unit
=> -1,
30127 Pragma_Compiler_Unit_Warning
=> -1,
30128 Pragma_Complete_Representation
=> 0,
30129 Pragma_Complex_Representation
=> 0,
30130 Pragma_Component_Alignment
=> 0,
30131 Pragma_Constant_After_Elaboration
=> 0,
30132 Pragma_Contract_Cases
=> -1,
30133 Pragma_Controlled
=> 0,
30134 Pragma_Convention
=> 0,
30135 Pragma_Convention_Identifier
=> 0,
30136 Pragma_Deadline_Floor
=> -1,
30137 Pragma_Debug
=> -1,
30138 Pragma_Debug_Policy
=> 0,
30139 Pragma_Detect_Blocking
=> 0,
30140 Pragma_Default_Initial_Condition
=> -1,
30141 Pragma_Default_Scalar_Storage_Order
=> 0,
30142 Pragma_Default_Storage_Pool
=> 0,
30143 Pragma_Depends
=> -1,
30144 Pragma_Disable_Atomic_Synchronization
=> 0,
30145 Pragma_Discard_Names
=> 0,
30146 Pragma_Dispatching_Domain
=> -1,
30147 Pragma_Effective_Reads
=> 0,
30148 Pragma_Effective_Writes
=> 0,
30149 Pragma_Elaborate
=> 0,
30150 Pragma_Elaborate_All
=> 0,
30151 Pragma_Elaborate_Body
=> 0,
30152 Pragma_Elaboration_Checks
=> 0,
30153 Pragma_Eliminate
=> 0,
30154 Pragma_Enable_Atomic_Synchronization
=> 0,
30155 Pragma_Export
=> -1,
30156 Pragma_Export_Function
=> -1,
30157 Pragma_Export_Object
=> -1,
30158 Pragma_Export_Procedure
=> -1,
30159 Pragma_Export_Value
=> -1,
30160 Pragma_Export_Valued_Procedure
=> -1,
30161 Pragma_Extend_System
=> -1,
30162 Pragma_Extensions_Allowed
=> 0,
30163 Pragma_Extensions_Visible
=> 0,
30164 Pragma_External
=> -1,
30165 Pragma_Favor_Top_Level
=> 0,
30166 Pragma_External_Name_Casing
=> 0,
30167 Pragma_Fast_Math
=> 0,
30168 Pragma_Finalize_Storage_Only
=> 0,
30170 Pragma_Global
=> -1,
30171 Pragma_Ident
=> -1,
30172 Pragma_Ignore_Pragma
=> 0,
30173 Pragma_Implementation_Defined
=> -1,
30174 Pragma_Implemented
=> -1,
30175 Pragma_Implicit_Packing
=> 0,
30176 Pragma_Import
=> 93,
30177 Pragma_Import_Function
=> 0,
30178 Pragma_Import_Object
=> 0,
30179 Pragma_Import_Procedure
=> 0,
30180 Pragma_Import_Valued_Procedure
=> 0,
30181 Pragma_Independent
=> 0,
30182 Pragma_Independent_Components
=> 0,
30183 Pragma_Initial_Condition
=> -1,
30184 Pragma_Initialize_Scalars
=> 0,
30185 Pragma_Initializes
=> -1,
30186 Pragma_Inline
=> 0,
30187 Pragma_Inline_Always
=> 0,
30188 Pragma_Inline_Generic
=> 0,
30189 Pragma_Inspection_Point
=> -1,
30190 Pragma_Interface
=> 92,
30191 Pragma_Interface_Name
=> 0,
30192 Pragma_Interrupt_Handler
=> -1,
30193 Pragma_Interrupt_Priority
=> -1,
30194 Pragma_Interrupt_State
=> -1,
30195 Pragma_Invariant
=> -1,
30196 Pragma_Keep_Names
=> 0,
30197 Pragma_License
=> 0,
30198 Pragma_Link_With
=> -1,
30199 Pragma_Linker_Alias
=> -1,
30200 Pragma_Linker_Constructor
=> -1,
30201 Pragma_Linker_Destructor
=> -1,
30202 Pragma_Linker_Options
=> -1,
30203 Pragma_Linker_Section
=> -1,
30205 Pragma_Lock_Free
=> 0,
30206 Pragma_Locking_Policy
=> 0,
30207 Pragma_Loop_Invariant
=> -1,
30208 Pragma_Loop_Optimize
=> 0,
30209 Pragma_Loop_Variant
=> -1,
30210 Pragma_Machine_Attribute
=> -1,
30212 Pragma_Main_Storage
=> -1,
30213 Pragma_Max_Entry_Queue_Depth
=> 0,
30214 Pragma_Max_Queue_Length
=> 0,
30215 Pragma_Memory_Size
=> 0,
30216 Pragma_No_Return
=> 0,
30217 Pragma_No_Body
=> 0,
30218 Pragma_No_Component_Reordering
=> -1,
30219 Pragma_No_Elaboration_Code_All
=> 0,
30220 Pragma_No_Heap_Finalization
=> 0,
30221 Pragma_No_Inline
=> 0,
30222 Pragma_No_Run_Time
=> -1,
30223 Pragma_No_Strict_Aliasing
=> -1,
30224 Pragma_No_Tagged_Streams
=> 0,
30225 Pragma_Normalize_Scalars
=> 0,
30226 Pragma_Obsolescent
=> 0,
30227 Pragma_Optimize
=> 0,
30228 Pragma_Optimize_Alignment
=> 0,
30229 Pragma_Overflow_Mode
=> 0,
30230 Pragma_Overriding_Renamings
=> 0,
30231 Pragma_Ordered
=> 0,
30234 Pragma_Part_Of
=> 0,
30235 Pragma_Partition_Elaboration_Policy
=> 0,
30236 Pragma_Passive
=> 0,
30237 Pragma_Persistent_BSS
=> 0,
30238 Pragma_Polling
=> 0,
30239 Pragma_Prefix_Exception_Messages
=> 0,
30241 Pragma_Postcondition
=> -1,
30242 Pragma_Post_Class
=> -1,
30244 Pragma_Precondition
=> -1,
30245 Pragma_Predicate
=> -1,
30246 Pragma_Predicate_Failure
=> -1,
30247 Pragma_Preelaborable_Initialization
=> -1,
30248 Pragma_Preelaborate
=> 0,
30249 Pragma_Pre_Class
=> -1,
30250 Pragma_Priority
=> -1,
30251 Pragma_Priority_Specific_Dispatching
=> 0,
30252 Pragma_Profile
=> 0,
30253 Pragma_Profile_Warnings
=> 0,
30254 Pragma_Propagate_Exceptions
=> 0,
30255 Pragma_Provide_Shift_Operators
=> 0,
30256 Pragma_Psect_Object
=> 0,
30258 Pragma_Pure_Function
=> 0,
30259 Pragma_Queuing_Policy
=> 0,
30260 Pragma_Rational
=> 0,
30261 Pragma_Ravenscar
=> 0,
30262 Pragma_Refined_Depends
=> -1,
30263 Pragma_Refined_Global
=> -1,
30264 Pragma_Refined_Post
=> -1,
30265 Pragma_Refined_State
=> -1,
30266 Pragma_Relative_Deadline
=> 0,
30267 Pragma_Rename_Pragma
=> 0,
30268 Pragma_Remote_Access_Type
=> -1,
30269 Pragma_Remote_Call_Interface
=> -1,
30270 Pragma_Remote_Types
=> -1,
30271 Pragma_Restricted_Run_Time
=> 0,
30272 Pragma_Restriction_Warnings
=> 0,
30273 Pragma_Restrictions
=> 0,
30274 Pragma_Reviewable
=> -1,
30275 Pragma_Secondary_Stack_Size
=> -1,
30276 Pragma_Short_Circuit_And_Or
=> 0,
30277 Pragma_Share_Generic
=> 0,
30278 Pragma_Shared
=> 0,
30279 Pragma_Shared_Passive
=> 0,
30280 Pragma_Short_Descriptors
=> 0,
30281 Pragma_Simple_Storage_Pool_Type
=> 0,
30282 Pragma_Source_File_Name
=> 0,
30283 Pragma_Source_File_Name_Project
=> 0,
30284 Pragma_Source_Reference
=> 0,
30285 Pragma_SPARK_Mode
=> 0,
30286 Pragma_Storage_Size
=> -1,
30287 Pragma_Storage_Unit
=> 0,
30288 Pragma_Static_Elaboration_Desired
=> 0,
30289 Pragma_Stream_Convert
=> 0,
30290 Pragma_Style_Checks
=> 0,
30291 Pragma_Subtitle
=> 0,
30292 Pragma_Suppress
=> 0,
30293 Pragma_Suppress_Exception_Locations
=> 0,
30294 Pragma_Suppress_All
=> 0,
30295 Pragma_Suppress_Debug_Info
=> 0,
30296 Pragma_Suppress_Initialization
=> 0,
30297 Pragma_System_Name
=> 0,
30298 Pragma_Task_Dispatching_Policy
=> 0,
30299 Pragma_Task_Info
=> -1,
30300 Pragma_Task_Name
=> -1,
30301 Pragma_Task_Storage
=> -1,
30302 Pragma_Test_Case
=> -1,
30303 Pragma_Thread_Local_Storage
=> -1,
30304 Pragma_Time_Slice
=> -1,
30306 Pragma_Type_Invariant
=> -1,
30307 Pragma_Type_Invariant_Class
=> -1,
30308 Pragma_Unchecked_Union
=> 0,
30309 Pragma_Unevaluated_Use_Of_Old
=> 0,
30310 Pragma_Unimplemented_Unit
=> 0,
30311 Pragma_Universal_Aliasing
=> 0,
30312 Pragma_Universal_Data
=> 0,
30313 Pragma_Unmodified
=> 0,
30314 Pragma_Unreferenced
=> 0,
30315 Pragma_Unreferenced_Objects
=> 0,
30316 Pragma_Unreserve_All_Interrupts
=> 0,
30317 Pragma_Unsuppress
=> 0,
30318 Pragma_Unused
=> 0,
30319 Pragma_Use_VADS_Size
=> 0,
30320 Pragma_Validity_Checks
=> 0,
30321 Pragma_Volatile
=> 0,
30322 Pragma_Volatile_Components
=> 0,
30323 Pragma_Volatile_Full_Access
=> 0,
30324 Pragma_Volatile_Function
=> 0,
30325 Pragma_Warning_As_Error
=> 0,
30326 Pragma_Warnings
=> 0,
30327 Pragma_Weak_External
=> 0,
30328 Pragma_Wide_Character_Encoding
=> 0,
30329 Unknown_Pragma
=> 0);
30331 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
30337 function Arg_No
return Nat
;
30338 -- Returns an integer showing what argument we are in. A value of
30339 -- zero means we are not in any of the arguments.
30345 function Arg_No
return Nat
is
30350 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
30364 -- Start of processing for Non_Significant_Pragma_Reference
30369 if Nkind
(P
) /= N_Pragma_Argument_Association
then
30373 Id
:= Get_Pragma_Id
(Parent
(P
));
30374 C
:= Sig_Flags
(Id
);
30389 return AN
< (C
- 90);
30395 end Is_Non_Significant_Pragma_Reference
;
30397 ------------------------------
30398 -- Is_Pragma_String_Literal --
30399 ------------------------------
30401 -- This function returns true if the corresponding pragma argument is a
30402 -- static string expression. These are the only cases in which string
30403 -- literals can appear as pragma arguments. We also allow a string literal
30404 -- as the first argument to pragma Assert (although it will of course
30405 -- always generate a type error).
30407 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
30408 Pragn
: constant Node_Id
:= Parent
(Par
);
30409 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
30410 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
30416 N
:= First
(Assoc
);
30423 if Pname
= Name_Assert
then
30426 elsif Pname
= Name_Export
then
30429 elsif Pname
= Name_Ident
then
30432 elsif Pname
= Name_Import
then
30435 elsif Pname
= Name_Interface_Name
then
30438 elsif Pname
= Name_Linker_Alias
then
30441 elsif Pname
= Name_Linker_Section
then
30444 elsif Pname
= Name_Machine_Attribute
then
30447 elsif Pname
= Name_Source_File_Name
then
30450 elsif Pname
= Name_Source_Reference
then
30453 elsif Pname
= Name_Title
then
30456 elsif Pname
= Name_Subtitle
then
30462 end Is_Pragma_String_Literal
;
30464 ---------------------------
30465 -- Is_Private_SPARK_Mode --
30466 ---------------------------
30468 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
30471 (Nkind
(N
) = N_Pragma
30472 and then Pragma_Name
(N
) = Name_SPARK_Mode
30473 and then Is_List_Member
(N
));
30475 -- For pragma SPARK_Mode to be private, it has to appear in the private
30476 -- declarations of a package.
30479 Present
(Parent
(N
))
30480 and then Nkind
(Parent
(N
)) = N_Package_Specification
30481 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
30482 end Is_Private_SPARK_Mode
;
30484 -------------------------------------
30485 -- Is_Unconstrained_Or_Tagged_Item --
30486 -------------------------------------
30488 function Is_Unconstrained_Or_Tagged_Item
30489 (Item
: Entity_Id
) return Boolean
30491 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
30492 -- Determine whether record type Typ has at least one unconstrained
30495 ---------------------------------
30496 -- Has_Unconstrained_Component --
30497 ---------------------------------
30499 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
30503 Comp
:= First_Component
(Typ
);
30504 while Present
(Comp
) loop
30505 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
30509 Next_Component
(Comp
);
30513 end Has_Unconstrained_Component
;
30517 Typ
: constant Entity_Id
:= Etype
(Item
);
30519 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30522 if Is_Tagged_Type
(Typ
) then
30525 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
30528 elsif Is_Record_Type
(Typ
) then
30529 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
30532 return Has_Unconstrained_Component
(Typ
);
30535 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
30541 end Is_Unconstrained_Or_Tagged_Item
;
30543 -----------------------------
30544 -- Is_Valid_Assertion_Kind --
30545 -----------------------------
30547 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
30554 | Name_Assertion_Policy
30555 | Name_Static_Predicate
30556 | Name_Dynamic_Predicate
30561 | Name_Type_Invariant
30562 | Name_uType_Invariant
30566 | Name_Assert_And_Cut
30568 | Name_Contract_Cases
30570 | Name_Default_Initial_Condition
30572 | Name_Initial_Condition
30575 | Name_Loop_Invariant
30576 | Name_Loop_Variant
30577 | Name_Postcondition
30578 | Name_Precondition
30580 | Name_Refined_Post
30581 | Name_Statement_Assertions
30588 end Is_Valid_Assertion_Kind
;
30590 --------------------------------------
30591 -- Process_Compilation_Unit_Pragmas --
30592 --------------------------------------
30594 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
30596 -- A special check for pragma Suppress_All, a very strange DEC pragma,
30597 -- strange because it comes at the end of the unit. Rational has the
30598 -- same name for a pragma, but treats it as a program unit pragma, In
30599 -- GNAT we just decide to allow it anywhere at all. If it appeared then
30600 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
30601 -- node, and we insert a pragma Suppress (All_Checks) at the start of
30602 -- the context clause to ensure the correct processing.
30604 if Has_Pragma_Suppress_All
(N
) then
30605 Prepend_To
(Context_Items
(N
),
30606 Make_Pragma
(Sloc
(N
),
30607 Chars
=> Name_Suppress
,
30608 Pragma_Argument_Associations
=> New_List
(
30609 Make_Pragma_Argument_Association
(Sloc
(N
),
30610 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
30613 -- Nothing else to do at the current time
30615 end Process_Compilation_Unit_Pragmas
;
30617 -------------------------------------------
30618 -- Process_Compile_Time_Warning_Or_Error --
30619 -------------------------------------------
30621 procedure Process_Compile_Time_Warning_Or_Error
30625 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
30626 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
30627 Arg2
: constant Node_Id
:= Next
(Arg1
);
30630 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
30632 if Compile_Time_Known_Value
(Arg1x
) then
30633 if Is_True
(Expr_Value
(Arg1x
)) then
30635 -- We have already verified that the second argument is a static
30636 -- string expression. Its string value must be retrieved
30637 -- explicitly if it is a declared constant, otherwise it has
30638 -- been constant-folded previously.
30641 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30642 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
30643 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
30644 Str
: constant String_Id
:=
30645 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
30646 Str_Len
: constant Nat
:= String_Length
(Str
);
30648 Force
: constant Boolean :=
30649 Prag_Id
= Pragma_Compile_Time_Warning
30650 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
30651 and then (Ekind
(Cent
) /= E_Package
30652 or else not In_Private_Part
(Cent
));
30653 -- Set True if this is the warning case, and we are in the
30654 -- visible part of a package spec, or in a subprogram spec,
30655 -- in which case we want to force the client to see the
30656 -- warning, even though it is not in the main unit.
30664 -- Loop through segments of message separated by line feeds.
30665 -- We output these segments as separate messages with
30666 -- continuation marks for all but the first.
30671 Error_Msg_Strlen
:= 0;
30673 -- Loop to copy characters from argument to error message
30677 exit when Ptr
> Str_Len
;
30678 CC
:= Get_String_Char
(Str
, Ptr
);
30681 -- Ignore wide chars ??? else store character
30683 if In_Character_Range
(CC
) then
30684 C
:= Get_Character
(CC
);
30685 exit when C
= ASCII
.LF
;
30686 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
30687 Error_Msg_String
(Error_Msg_Strlen
) := C
;
30691 -- Here with one line ready to go
30693 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
30695 -- If this is a warning in a spec, then we want clients
30696 -- to see the warning, so mark the message with the
30697 -- special sequence !! to force the warning. In the case
30698 -- of a package spec, we do not force this if we are in
30699 -- the private part of the spec.
30702 if Cont
= False then
30703 Error_Msg
("<<~!!", Eloc
);
30706 Error_Msg
("\<<~!!", Eloc
);
30709 -- Error, rather than warning, or in a body, so we do not
30710 -- need to force visibility for client (error will be
30711 -- output in any case, and this is the situation in which
30712 -- we do not want a client to get a warning, since the
30713 -- warning is in the body or the spec private part).
30716 if Cont
= False then
30717 Error_Msg
("<<~", Eloc
);
30720 Error_Msg
("\<<~", Eloc
);
30724 exit when Ptr
> Str_Len
;
30729 end Process_Compile_Time_Warning_Or_Error
;
30731 ------------------------------------
30732 -- Record_Possible_Body_Reference --
30733 ------------------------------------
30735 procedure Record_Possible_Body_Reference
30736 (State_Id
: Entity_Id
;
30740 Spec_Id
: Entity_Id
;
30743 -- Ensure that we are dealing with a reference to a state
30745 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
30747 -- Climb the tree starting from the reference looking for a package body
30748 -- whose spec declares the referenced state. This criteria automatically
30749 -- excludes references in package specs which are legal. Note that it is
30750 -- not wise to emit an error now as the package body may lack pragma
30751 -- Refined_State or the referenced state may not be mentioned in the
30752 -- refinement. This approach avoids the generation of misleading errors.
30755 while Present
(Context
) loop
30756 if Nkind
(Context
) = N_Package_Body
then
30757 Spec_Id
:= Corresponding_Spec
(Context
);
30759 if Present
(Abstract_States
(Spec_Id
))
30760 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
30762 if No
(Body_References
(State_Id
)) then
30763 Set_Body_References
(State_Id
, New_Elmt_List
);
30766 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
30771 Context
:= Parent
(Context
);
30773 end Record_Possible_Body_Reference
;
30775 ------------------------------------------
30776 -- Relocate_Pragmas_To_Anonymous_Object --
30777 ------------------------------------------
30779 procedure Relocate_Pragmas_To_Anonymous_Object
30780 (Typ_Decl
: Node_Id
;
30781 Obj_Decl
: Node_Id
)
30785 Next_Decl
: Node_Id
;
30788 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
30789 Def
:= Protected_Definition
(Typ_Decl
);
30791 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
30792 Def
:= Task_Definition
(Typ_Decl
);
30795 -- The concurrent definition has a visible declaration list. Inspect it
30796 -- and relocate all canidate pragmas.
30798 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
30799 Decl
:= First
(Visible_Declarations
(Def
));
30800 while Present
(Decl
) loop
30802 -- Preserve the following declaration for iteration purposes due
30803 -- to possible relocation of a pragma.
30805 Next_Decl
:= Next
(Decl
);
30807 if Nkind
(Decl
) = N_Pragma
30808 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
30811 Insert_After
(Obj_Decl
, Decl
);
30813 -- Skip internally generated code
30815 elsif not Comes_From_Source
(Decl
) then
30818 -- No candidate pragmas are available for relocation
30827 end Relocate_Pragmas_To_Anonymous_Object
;
30829 ------------------------------
30830 -- Relocate_Pragmas_To_Body --
30831 ------------------------------
30833 procedure Relocate_Pragmas_To_Body
30834 (Subp_Body
: Node_Id
;
30835 Target_Body
: Node_Id
:= Empty
)
30837 procedure Relocate_Pragma
(Prag
: Node_Id
);
30838 -- Remove a single pragma from its current list and add it to the
30839 -- declarations of the proper body (either Subp_Body or Target_Body).
30841 ---------------------
30842 -- Relocate_Pragma --
30843 ---------------------
30845 procedure Relocate_Pragma
(Prag
: Node_Id
) is
30850 -- When subprogram stubs or expression functions are involves, the
30851 -- destination declaration list belongs to the proper body.
30853 if Present
(Target_Body
) then
30854 Target
:= Target_Body
;
30856 Target
:= Subp_Body
;
30859 Decls
:= Declarations
(Target
);
30863 Set_Declarations
(Target
, Decls
);
30866 -- Unhook the pragma from its current list
30869 Prepend
(Prag
, Decls
);
30870 end Relocate_Pragma
;
30874 Body_Id
: constant Entity_Id
:=
30875 Defining_Unit_Name
(Specification
(Subp_Body
));
30876 Next_Stmt
: Node_Id
;
30879 -- Start of processing for Relocate_Pragmas_To_Body
30882 -- Do not process a body that comes from a separate unit as no construct
30883 -- can possibly follow it.
30885 if not Is_List_Member
(Subp_Body
) then
30888 -- Do not relocate pragmas that follow a stub if the stub does not have
30891 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
30892 and then No
(Target_Body
)
30896 -- Do not process internally generated routine _Postconditions
30898 elsif Ekind
(Body_Id
) = E_Procedure
30899 and then Chars
(Body_Id
) = Name_uPostconditions
30904 -- Look at what is following the body. We are interested in certain kind
30905 -- of pragmas (either from source or byproducts of expansion) that can
30906 -- apply to a body [stub].
30908 Stmt
:= Next
(Subp_Body
);
30909 while Present
(Stmt
) loop
30911 -- Preserve the following statement for iteration purposes due to a
30912 -- possible relocation of a pragma.
30914 Next_Stmt
:= Next
(Stmt
);
30916 -- Move a candidate pragma following the body to the declarations of
30919 if Nkind
(Stmt
) = N_Pragma
30920 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
30923 -- If a source pragma Warnings follows the body, it applies to
30924 -- following statements and does not belong in the body.
30926 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
30927 and then Comes_From_Source
(Stmt
)
30931 Relocate_Pragma
(Stmt
);
30934 -- Skip internally generated code
30936 elsif not Comes_From_Source
(Stmt
) then
30939 -- No candidate pragmas are available for relocation
30947 end Relocate_Pragmas_To_Body
;
30949 -------------------
30950 -- Resolve_State --
30951 -------------------
30953 procedure Resolve_State
(N
: Node_Id
) is
30958 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30959 Func
:= Entity
(N
);
30961 -- Handle overloading of state names by functions. Traverse the
30962 -- homonym chain looking for an abstract state.
30964 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30965 pragma Assert
(Is_Overloaded
(N
));
30967 State
:= Homonym
(Func
);
30968 while Present
(State
) loop
30969 if Ekind
(State
) = E_Abstract_State
then
30971 -- Resolve the overloading by setting the proper entity of
30972 -- the reference to that of the state.
30974 Set_Etype
(N
, Standard_Void_Type
);
30975 Set_Entity
(N
, State
);
30976 Set_Is_Overloaded
(N
, False);
30978 Generate_Reference
(State
, N
);
30982 State
:= Homonym
(State
);
30985 -- A function can never act as a state. If the homonym chain does
30986 -- not contain a corresponding state, then something went wrong in
30987 -- the overloading mechanism.
30989 raise Program_Error
;
30994 ----------------------------
30995 -- Rewrite_Assertion_Kind --
30996 ----------------------------
30998 procedure Rewrite_Assertion_Kind
31000 From_Policy
: Boolean := False)
31006 if Nkind
(N
) = N_Attribute_Reference
31007 and then Attribute_Name
(N
) = Name_Class
31008 and then Nkind
(Prefix
(N
)) = N_Identifier
31010 case Chars
(Prefix
(N
)) is
31017 when Name_Type_Invariant
=>
31018 Nam
:= Name_uType_Invariant
;
31020 when Name_Invariant
=>
31021 Nam
:= Name_uInvariant
;
31027 -- Recommend standard use of aspect names Pre/Post
31029 elsif Nkind
(N
) = N_Identifier
31030 and then From_Policy
31031 and then Serious_Errors_Detected
= 0
31032 and then not ASIS_Mode
31034 if Chars
(N
) = Name_Precondition
31035 or else Chars
(N
) = Name_Postcondition
31037 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
31039 ("\use Assertion_Policy and aspect names Pre/Post for "
31040 & "Ada2012 conformance?", N
);
31046 if Nam
/= No_Name
then
31047 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
31049 end Rewrite_Assertion_Kind
;
31057 Dummy
:= Dummy
+ 1;
31060 --------------------------------
31061 -- Set_Encoded_Interface_Name --
31062 --------------------------------
31064 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
31065 Str
: constant String_Id
:= Strval
(S
);
31066 Len
: constant Nat
:= String_Length
(Str
);
31071 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
31074 -- Stores encoded value of character code CC. The encoding we use an
31075 -- underscore followed by four lower case hex digits.
31081 procedure Encode
is
31083 Store_String_Char
(Get_Char_Code
('_'));
31085 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
31087 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
31089 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
31091 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
31094 -- Start of processing for Set_Encoded_Interface_Name
31097 -- If first character is asterisk, this is a link name, and we leave it
31098 -- completely unmodified. We also ignore null strings (the latter case
31099 -- happens only in error cases).
31102 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
31104 Set_Interface_Name
(E
, S
);
31109 CC
:= Get_String_Char
(Str
, J
);
31111 exit when not In_Character_Range
(CC
);
31113 C
:= Get_Character
(CC
);
31115 exit when C
/= '_' and then C
/= '$'
31116 and then C
not in '0' .. '9'
31117 and then C
not in 'a' .. 'z'
31118 and then C
not in 'A' .. 'Z';
31121 Set_Interface_Name
(E
, S
);
31129 -- Here we need to encode. The encoding we use as follows:
31130 -- three underscores + four hex digits (lower case)
31134 for J
in 1 .. String_Length
(Str
) loop
31135 CC
:= Get_String_Char
(Str
, J
);
31137 if not In_Character_Range
(CC
) then
31140 C
:= Get_Character
(CC
);
31142 if C
= '_' or else C
= '$'
31143 or else C
in '0' .. '9'
31144 or else C
in 'a' .. 'z'
31145 or else C
in 'A' .. 'Z'
31147 Store_String_Char
(CC
);
31154 Set_Interface_Name
(E
,
31155 Make_String_Literal
(Sloc
(S
),
31156 Strval
=> End_String
));
31158 end Set_Encoded_Interface_Name
;
31160 ------------------------
31161 -- Set_Elab_Unit_Name --
31162 ------------------------
31164 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
31169 if Nkind
(N
) = N_Identifier
31170 and then Nkind
(With_Item
) = N_Identifier
31172 Set_Entity
(N
, Entity
(With_Item
));
31174 elsif Nkind
(N
) = N_Selected_Component
then
31175 Change_Selected_Component_To_Expanded_Name
(N
);
31176 Set_Entity
(N
, Entity
(With_Item
));
31177 Set_Entity
(Selector_Name
(N
), Entity
(N
));
31179 Pref
:= Prefix
(N
);
31180 Scop
:= Scope
(Entity
(N
));
31181 while Nkind
(Pref
) = N_Selected_Component
loop
31182 Change_Selected_Component_To_Expanded_Name
(Pref
);
31183 Set_Entity
(Selector_Name
(Pref
), Scop
);
31184 Set_Entity
(Pref
, Scop
);
31185 Pref
:= Prefix
(Pref
);
31186 Scop
:= Scope
(Scop
);
31189 Set_Entity
(Pref
, Scop
);
31192 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
31193 end Set_Elab_Unit_Name
;
31195 -------------------
31196 -- Test_Case_Arg --
31197 -------------------
31199 function Test_Case_Arg
31202 From_Aspect
: Boolean := False) return Node_Id
31204 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
31209 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
31214 -- The caller requests the aspect argument
31216 if From_Aspect
then
31217 if Present
(Aspect
)
31218 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
31220 Args
:= Expression
(Aspect
);
31222 -- "Name" and "Mode" may appear without an identifier as a
31223 -- positional association.
31225 if Present
(Expressions
(Args
)) then
31226 Arg
:= First
(Expressions
(Args
));
31228 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31236 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31241 -- Some or all arguments may appear as component associatons
31243 if Present
(Component_Associations
(Args
)) then
31244 Arg
:= First
(Component_Associations
(Args
));
31245 while Present
(Arg
) loop
31246 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
31255 -- Otherwise retrieve the argument directly from the pragma
31258 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
31260 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31264 -- Skip argument "Name"
31268 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31272 -- Skip argument "Mode"
31276 -- Arguments "Requires" and "Ensures" are optional and may not be
31279 while Present
(Arg
) loop
31280 if Chars
(Arg
) = Arg_Nam
then