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 an
2132 -- input in the Global aspect of an enclosing subprogram. If this is
2133 -- the case, emit an error. Item and Item_Id are respectively the
2134 -- 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
2487 -- subject to pragma [Refined_]Global.
2489 Context
:= Scope
(Subp_Id
);
2490 while Present
(Context
) and then Context
/= Standard_Standard
loop
2491 if Is_Subprogram
(Context
)
2493 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2495 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2497 Collect_Subprogram_Inputs_Outputs
2498 (Subp_Id
=> Context
,
2499 Subp_Inputs
=> Inputs
,
2500 Subp_Outputs
=> Outputs
,
2501 Global_Seen
=> Dummy
);
2503 -- The item is classified as In_Out or Output but appears as
2504 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2506 if Appears_In
(Inputs
, Item_Id
)
2507 and then not Appears_In
(Outputs
, Item_Id
)
2510 ("global item & cannot have mode In_Out or Output",
2514 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2515 & "subprogram &"), Item
, Context
);
2517 -- Stop the traversal once an error has been detected
2523 Context
:= Scope
(Context
);
2525 end Check_Mode_Restriction_In_Enclosing_Context
;
2527 ----------------------------------------
2528 -- Check_Mode_Restriction_In_Function --
2529 ----------------------------------------
2531 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2533 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2535 ("global mode & is not applicable to functions", Mode
);
2537 end Check_Mode_Restriction_In_Function
;
2545 -- Start of processing for Analyze_Global_List
2548 if Nkind
(List
) = N_Null
then
2549 Set_Analyzed
(List
);
2551 -- Single global item declaration
2553 elsif Nkind_In
(List
, N_Expanded_Name
,
2555 N_Selected_Component
)
2557 Analyze_Global_Item
(List
, Global_Mode
);
2559 -- Simple global list or moded global list declaration
2561 elsif Nkind
(List
) = N_Aggregate
then
2562 Set_Analyzed
(List
);
2564 -- The declaration of a simple global list appear as a collection
2567 if Present
(Expressions
(List
)) then
2568 if Present
(Component_Associations
(List
)) then
2570 ("cannot mix moded and non-moded global lists", List
);
2573 Item
:= First
(Expressions
(List
));
2574 while Present
(Item
) loop
2575 Analyze_Global_Item
(Item
, Global_Mode
);
2579 -- The declaration of a moded global list appears as a collection
2580 -- of component associations where individual choices denote
2583 elsif Present
(Component_Associations
(List
)) then
2584 if Present
(Expressions
(List
)) then
2586 ("cannot mix moded and non-moded global lists", List
);
2589 Assoc
:= First
(Component_Associations
(List
));
2590 while Present
(Assoc
) loop
2591 Mode
:= First
(Choices
(Assoc
));
2593 if Nkind
(Mode
) = N_Identifier
then
2594 if Chars
(Mode
) = Name_In_Out
then
2595 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2596 Check_Mode_Restriction_In_Function
(Mode
);
2598 elsif Chars
(Mode
) = Name_Input
then
2599 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2601 elsif Chars
(Mode
) = Name_Output
then
2602 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2603 Check_Mode_Restriction_In_Function
(Mode
);
2605 elsif Chars
(Mode
) = Name_Proof_In
then
2606 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2609 SPARK_Msg_N
("invalid mode selector", Mode
);
2613 SPARK_Msg_N
("invalid mode selector", Mode
);
2616 -- Items in a moded list appear as a collection of
2617 -- expressions. Reuse the existing machinery to analyze
2621 (List
=> Expression
(Assoc
),
2622 Global_Mode
=> Chars
(Mode
));
2630 raise Program_Error
;
2633 -- Any other attempt to declare a global item is illegal. This is a
2634 -- syntax error, always report.
2637 Error_Msg_N
("malformed global list", List
);
2639 end Analyze_Global_List
;
2643 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2645 Restore_Scope
: Boolean := False;
2647 -- Start of processing for Analyze_Global_In_Decl_Part
2650 -- Do not analyze the pragma multiple times
2652 if Is_Analyzed_Pragma
(N
) then
2656 -- There is nothing to be done for a null global list
2658 if Nkind
(Items
) = N_Null
then
2659 Set_Analyzed
(Items
);
2661 -- Analyze the various forms of global lists and items. Note that some
2662 -- of these may be malformed in which case the analysis emits error
2666 -- When pragma [Refined_]Global appears on a single concurrent type,
2667 -- it is relocated to the anonymous object.
2669 if Is_Single_Concurrent_Object
(Spec_Id
) then
2672 -- Ensure that the formal parameters are visible when processing an
2673 -- item. This falls out of the general rule of aspects pertaining to
2674 -- subprogram declarations.
2676 elsif not In_Open_Scopes
(Spec_Id
) then
2677 Restore_Scope
:= True;
2678 Push_Scope
(Spec_Id
);
2680 if Ekind
(Spec_Id
) = E_Task_Type
then
2681 if Has_Discriminants
(Spec_Id
) then
2682 Install_Discriminants
(Spec_Id
);
2685 elsif Is_Generic_Subprogram
(Spec_Id
) then
2686 Install_Generic_Formals
(Spec_Id
);
2689 Install_Formals
(Spec_Id
);
2693 Analyze_Global_List
(Items
);
2695 if Restore_Scope
then
2700 -- Ensure that a state and a corresponding constituent do not appear
2701 -- together in pragma [Refined_]Global.
2703 Check_State_And_Constituent_Use
2704 (States
=> States_Seen
,
2705 Constits
=> Constits_Seen
,
2708 Set_Is_Analyzed_Pragma
(N
);
2709 end Analyze_Global_In_Decl_Part
;
2711 --------------------------------------------
2712 -- Analyze_Initial_Condition_In_Decl_Part --
2713 --------------------------------------------
2715 -- WARNING: This routine manages Ghost regions. Return statements must be
2716 -- replaced by gotos which jump to the end of the routine and restore the
2719 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2720 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2721 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2722 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2724 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2725 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2726 -- Save the Ghost-related attributes to restore on exit
2729 -- Do not analyze the pragma multiple times
2731 if Is_Analyzed_Pragma
(N
) then
2735 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2736 -- analysis of the pragma, the Ghost mode at point of declaration and
2737 -- point of analysis may not necessarily be the same. Use the mode in
2738 -- effect at the point of declaration.
2742 -- The expression is preanalyzed because it has not been moved to its
2743 -- final place yet. A direct analysis may generate side effects and this
2744 -- is not desired at this point.
2746 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2747 Set_Is_Analyzed_Pragma
(N
);
2749 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2750 end Analyze_Initial_Condition_In_Decl_Part
;
2752 --------------------------------------
2753 -- Analyze_Initializes_In_Decl_Part --
2754 --------------------------------------
2756 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2757 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2758 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2760 Constits_Seen
: Elist_Id
:= No_Elist
;
2761 -- A list containing the entities of all constituents processed so far.
2762 -- It aids in detecting illegal usage of a state and a corresponding
2763 -- constituent in pragma Initializes.
2765 Items_Seen
: Elist_Id
:= No_Elist
;
2766 -- A list of all initialization items processed so far. This list is
2767 -- used to detect duplicate items.
2769 States_And_Objs
: Elist_Id
:= No_Elist
;
2770 -- A list of all abstract states and objects declared in the visible
2771 -- declarations of the related package. This list is used to detect the
2772 -- legality of initialization items.
2774 States_Seen
: Elist_Id
:= No_Elist
;
2775 -- A list containing the entities of all states processed so far. It
2776 -- helps in detecting illegal usage of a state and a corresponding
2777 -- constituent in pragma Initializes.
2779 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2780 -- Verify the legality of a single initialization item
2782 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2783 -- Verify the legality of a single initialization item followed by a
2784 -- list of input items.
2786 procedure Collect_States_And_Objects
;
2787 -- Inspect the visible declarations of the related package and gather
2788 -- the entities of all abstract states and objects in States_And_Objs.
2790 ---------------------------------
2791 -- Analyze_Initialization_Item --
2792 ---------------------------------
2794 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2795 Item_Id
: Entity_Id
;
2799 Resolve_State
(Item
);
2801 if Is_Entity_Name
(Item
) then
2802 Item_Id
:= Entity_Of
(Item
);
2804 if Present
(Item_Id
)
2805 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2809 -- When the initialization item is undefined, it appears as
2810 -- Any_Id. Do not continue with the analysis of the item.
2812 if Item_Id
= Any_Id
then
2815 -- The state or variable must be declared in the visible
2816 -- declarations of the package (SPARK RM 7.1.5(7)).
2818 elsif not Contains
(States_And_Objs
, Item_Id
) then
2819 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2821 ("initialization item & must appear in the visible "
2822 & "declarations of package %", Item
, Item_Id
);
2824 -- Detect a duplicate use of the same initialization item
2825 -- (SPARK RM 7.1.5(5)).
2827 elsif Contains
(Items_Seen
, Item_Id
) then
2828 SPARK_Msg_N
("duplicate initialization item", Item
);
2830 -- The item is legal, add it to the list of processed states
2834 Append_New_Elmt
(Item_Id
, Items_Seen
);
2836 if Ekind
(Item_Id
) = E_Abstract_State
then
2837 Append_New_Elmt
(Item_Id
, States_Seen
);
2840 if Present
(Encapsulating_State
(Item_Id
)) then
2841 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2845 -- The item references something that is not a state or object
2846 -- (SPARK RM 7.1.5(3)).
2850 ("initialization item must denote object or state", Item
);
2853 -- Some form of illegal construct masquerading as a name
2854 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2858 ("initialization item must denote object or state", Item
);
2860 end Analyze_Initialization_Item
;
2862 ---------------------------------------------
2863 -- Analyze_Initialization_Item_With_Inputs --
2864 ---------------------------------------------
2866 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2867 Inputs_Seen
: Elist_Id
:= No_Elist
;
2868 -- A list of all inputs processed so far. This list is used to detect
2869 -- duplicate uses of an input.
2871 Non_Null_Seen
: Boolean := False;
2872 Null_Seen
: Boolean := False;
2873 -- Flags used to check the legality of an input list
2875 procedure Analyze_Input_Item
(Input
: Node_Id
);
2876 -- Verify the legality of a single input item
2878 ------------------------
2879 -- Analyze_Input_Item --
2880 ------------------------
2882 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2883 Input_Id
: Entity_Id
;
2888 if Nkind
(Input
) = N_Null
then
2891 ("multiple null initializations not allowed", Item
);
2893 elsif Non_Null_Seen
then
2895 ("cannot mix null and non-null initialization item", Item
);
2903 Non_Null_Seen
:= True;
2907 ("cannot mix null and non-null initialization item", Item
);
2911 Resolve_State
(Input
);
2913 if Is_Entity_Name
(Input
) then
2914 Input_Id
:= Entity_Of
(Input
);
2916 if Present
(Input_Id
)
2917 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2919 E_Generic_In_Out_Parameter
,
2920 E_Generic_In_Parameter
,
2928 -- The input cannot denote states or objects declared
2929 -- within the related package (SPARK RM 7.1.5(4)).
2931 if Within_Scope
(Input_Id
, Current_Scope
) then
2933 -- Do not consider generic formal parameters or their
2934 -- respective mappings to generic formals. Even though
2935 -- the formals appear within the scope of the package,
2936 -- it is allowed for an initialization item to depend
2937 -- on an input item.
2939 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2940 E_Generic_In_Parameter
)
2944 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2945 and then Present
(Corresponding_Generic_Association
2946 (Declaration_Node
(Input_Id
)))
2951 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2953 ("input item & cannot denote a visible object or "
2954 & "state of package %", Input
, Input_Id
);
2959 -- Detect a duplicate use of the same input item
2960 -- (SPARK RM 7.1.5(5)).
2962 if Contains
(Inputs_Seen
, Input_Id
) then
2963 SPARK_Msg_N
("duplicate input item", Input
);
2967 -- At this point it is known that the input is legal. Add
2968 -- it to the list of processed inputs.
2970 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2972 if Ekind
(Input_Id
) = E_Abstract_State
then
2973 Append_New_Elmt
(Input_Id
, States_Seen
);
2976 if Ekind_In
(Input_Id
, E_Abstract_State
,
2979 and then Present
(Encapsulating_State
(Input_Id
))
2981 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2984 -- The input references something that is not a state or an
2985 -- object (SPARK RM 7.1.5(3)).
2989 ("input item must denote object or state", Input
);
2992 -- Some form of illegal construct masquerading as a name
2993 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2997 ("input item must denote object or state", Input
);
3000 end Analyze_Input_Item
;
3004 Inputs
: constant Node_Id
:= Expression
(Item
);
3008 Name_Seen
: Boolean := False;
3009 -- A flag used to detect multiple item names
3011 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3014 -- Inspect the name of an item with inputs
3016 Elmt
:= First
(Choices
(Item
));
3017 while Present
(Elmt
) loop
3019 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3022 Analyze_Initialization_Item
(Elmt
);
3028 -- Multiple input items appear as an aggregate
3030 if Nkind
(Inputs
) = N_Aggregate
then
3031 if Present
(Expressions
(Inputs
)) then
3032 Input
:= First
(Expressions
(Inputs
));
3033 while Present
(Input
) loop
3034 Analyze_Input_Item
(Input
);
3039 if Present
(Component_Associations
(Inputs
)) then
3041 ("inputs must appear in named association form", Inputs
);
3044 -- Single input item
3047 Analyze_Input_Item
(Inputs
);
3049 end Analyze_Initialization_Item_With_Inputs
;
3051 --------------------------------
3052 -- Collect_States_And_Objects --
3053 --------------------------------
3055 procedure Collect_States_And_Objects
is
3056 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3060 -- Collect the abstract states defined in the package (if any)
3062 if Present
(Abstract_States
(Pack_Id
)) then
3063 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3066 -- Collect all objects that appear in the visible declarations of the
3069 if Present
(Visible_Declarations
(Pack_Spec
)) then
3070 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3071 while Present
(Decl
) loop
3072 if Comes_From_Source
(Decl
)
3073 and then Nkind_In
(Decl
, N_Object_Declaration
,
3074 N_Object_Renaming_Declaration
)
3076 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3078 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3080 (Anonymous_Object
(Defining_Entity
(Decl
)),
3087 end Collect_States_And_Objects
;
3091 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3094 -- Start of processing for Analyze_Initializes_In_Decl_Part
3097 -- Do not analyze the pragma multiple times
3099 if Is_Analyzed_Pragma
(N
) then
3103 -- Nothing to do when the initialization list is empty
3105 if Nkind
(Inits
) = N_Null
then
3109 -- Single and multiple initialization clauses appear as an aggregate. If
3110 -- this is not the case, then either the parser or the analysis of the
3111 -- pragma failed to produce an aggregate.
3113 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3115 -- Initialize the various lists used during analysis
3117 Collect_States_And_Objects
;
3119 if Present
(Expressions
(Inits
)) then
3120 Init
:= First
(Expressions
(Inits
));
3121 while Present
(Init
) loop
3122 Analyze_Initialization_Item
(Init
);
3127 if Present
(Component_Associations
(Inits
)) then
3128 Init
:= First
(Component_Associations
(Inits
));
3129 while Present
(Init
) loop
3130 Analyze_Initialization_Item_With_Inputs
(Init
);
3135 -- Ensure that a state and a corresponding constituent do not appear
3136 -- together in pragma Initializes.
3138 Check_State_And_Constituent_Use
3139 (States
=> States_Seen
,
3140 Constits
=> Constits_Seen
,
3143 Set_Is_Analyzed_Pragma
(N
);
3144 end Analyze_Initializes_In_Decl_Part
;
3146 ---------------------
3147 -- Analyze_Part_Of --
3148 ---------------------
3150 procedure Analyze_Part_Of
3152 Item_Id
: Entity_Id
;
3154 Encap_Id
: out Entity_Id
;
3155 Legal
: out Boolean)
3157 procedure Check_Part_Of_Abstract_State
;
3158 pragma Inline
(Check_Part_Of_Abstract_State
);
3159 -- Verify the legality of indicator Part_Of when the encapsulator is an
3162 procedure Check_Part_Of_Concurrent_Type
;
3163 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3164 -- Verify the legality of indicator Part_Of when the encapsulator is a
3165 -- single concurrent type.
3167 ----------------------------------
3168 -- Check_Part_Of_Abstract_State --
3169 ----------------------------------
3171 procedure Check_Part_Of_Abstract_State
is
3172 Pack_Id
: Entity_Id
;
3173 Placement
: State_Space_Kind
;
3174 Parent_Unit
: Entity_Id
;
3177 -- Determine where the object, package instantiation or state lives
3178 -- with respect to the enclosing packages or package bodies.
3180 Find_Placement_In_State_Space
3181 (Item_Id
=> Item_Id
,
3182 Placement
=> Placement
,
3183 Pack_Id
=> Pack_Id
);
3185 -- The item appears in a non-package construct with a declarative
3186 -- part (subprogram, block, etc). As such, the item is not allowed
3187 -- to be a part of an encapsulating state because the item is not
3190 if Placement
= Not_In_Package
then
3192 ("indicator Part_Of cannot appear in this context "
3193 & "(SPARK RM 7.2.6(5))", Indic
);
3195 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3197 ("\& is not part of the hidden state of package %",
3201 -- The item appears in the visible state space of some package. In
3202 -- general this scenario does not warrant Part_Of except when the
3203 -- package is a private child unit and the encapsulating state is
3204 -- declared in a parent unit or a public descendant of that parent
3207 elsif Placement
= Visible_State_Space
then
3208 if Is_Child_Unit
(Pack_Id
)
3209 and then Is_Private_Descendant
(Pack_Id
)
3211 -- A variable or state abstraction which is part of the visible
3212 -- state of a private child unit or its public descendants must
3213 -- have its Part_Of indicator specified. The Part_Of indicator
3214 -- must denote a state declared by either the parent unit of
3215 -- the private unit or by a public descendant of that parent
3218 -- Find the nearest private ancestor (which can be the current
3221 Parent_Unit
:= Pack_Id
;
3222 while Present
(Parent_Unit
) loop
3225 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3226 Parent_Unit
:= Scope
(Parent_Unit
);
3229 Parent_Unit
:= Scope
(Parent_Unit
);
3231 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3233 ("indicator Part_Of must denote abstract state of & or of "
3234 & "its public descendant (SPARK RM 7.2.6(3))",
3235 Indic
, Parent_Unit
);
3238 elsif Scope
(Encap_Id
) = Parent_Unit
3240 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3241 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3247 ("indicator Part_Of must denote abstract state of & or of "
3248 & "its public descendant (SPARK RM 7.2.6(3))",
3249 Indic
, Parent_Unit
);
3253 -- Indicator Part_Of is not needed when the related package is not
3254 -- a private child unit or a public descendant thereof.
3258 ("indicator Part_Of cannot appear in this context "
3259 & "(SPARK RM 7.2.6(5))", Indic
);
3261 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3263 ("\& is declared in the visible part of package %",
3268 -- When the item appears in the private state space of a package, the
3269 -- encapsulating state must be declared in the same package.
3271 elsif Placement
= Private_State_Space
then
3272 if Scope
(Encap_Id
) /= Pack_Id
then
3274 ("indicator Part_Of must denote an abstract state of "
3275 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3277 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3279 ("\& is declared in the private part of package %",
3284 -- Items declared in the body state space of a package do not need
3285 -- Part_Of indicators as the refinement has already been seen.
3289 ("indicator Part_Of cannot appear in this context "
3290 & "(SPARK RM 7.2.6(5))", Indic
);
3292 if Scope
(Encap_Id
) = Pack_Id
then
3293 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3295 ("\& is declared in the body of package %", Indic
, Item_Id
);
3301 -- At this point it is known that the Part_Of indicator is legal
3304 end Check_Part_Of_Abstract_State
;
3306 -----------------------------------
3307 -- Check_Part_Of_Concurrent_Type --
3308 -----------------------------------
3310 procedure Check_Part_Of_Concurrent_Type
is
3311 function In_Proper_Order
3313 Second
: Node_Id
) return Boolean;
3314 pragma Inline
(In_Proper_Order
);
3315 -- Determine whether node First precedes node Second
3317 procedure Placement_Error
;
3318 pragma Inline
(Placement_Error
);
3319 -- Emit an error concerning the illegal placement of the item with
3320 -- respect to the single concurrent type.
3322 ---------------------
3323 -- In_Proper_Order --
3324 ---------------------
3326 function In_Proper_Order
3328 Second
: Node_Id
) return Boolean
3333 if List_Containing
(First
) = List_Containing
(Second
) then
3335 while Present
(N
) loop
3345 end In_Proper_Order
;
3347 ---------------------
3348 -- Placement_Error --
3349 ---------------------
3351 procedure Placement_Error
is
3354 ("indicator Part_Of must denote a previously declared single "
3355 & "protected type or single task type", Encap
);
3356 end Placement_Error
;
3360 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3361 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3362 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3364 Item_Context
: Node_Id
;
3365 Item_Decl
: Node_Id
;
3366 Prv_Decls
: List_Id
;
3367 Vis_Decls
: List_Id
;
3369 -- Start of processing for Check_Part_Of_Concurrent_Type
3372 -- Only abstract states and variables can act as constituents of an
3373 -- encapsulating single concurrent type.
3375 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3378 -- The constituent is a constant
3380 elsif Ekind
(Item_Id
) = E_Constant
then
3381 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3383 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3384 & "single protected type %"), Indic
, Item_Id
);
3387 -- The constituent is a package instantiation
3390 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3392 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3393 & "constituent of single protected type %"), Indic
, Item_Id
);
3397 -- When the item denotes an abstract state of a nested package, use
3398 -- the declaration of the package to detect proper placement.
3403 -- with Abstract_State => (State with Part_Of => T)
3405 if Ekind
(Item_Id
) = E_Abstract_State
then
3406 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3408 Item_Decl
:= Declaration_Node
(Item_Id
);
3411 Item_Context
:= Parent
(Item_Decl
);
3413 -- The item and the single concurrent type must appear in the same
3414 -- declarative region, with the item following the declaration of
3415 -- the single concurrent type (SPARK RM 9(3)).
3417 if Item_Context
= Encap_Context
then
3418 if Nkind_In
(Item_Context
, N_Package_Specification
,
3419 N_Protected_Definition
,
3422 Prv_Decls
:= Private_Declarations
(Item_Context
);
3423 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3425 -- The placement is OK when the single concurrent type appears
3426 -- within the visible declarations and the item in the private
3432 -- Constit : ... with Part_Of => PO;
3435 if List_Containing
(Encap_Decl
) = Vis_Decls
3436 and then List_Containing
(Item_Decl
) = Prv_Decls
3440 -- The placement is illegal when the item appears within the
3441 -- visible declarations and the single concurrent type is in
3442 -- the private declarations.
3445 -- Constit : ... with Part_Of => PO;
3450 elsif List_Containing
(Item_Decl
) = Vis_Decls
3451 and then List_Containing
(Encap_Decl
) = Prv_Decls
3456 -- Otherwise both the item and the single concurrent type are
3457 -- in the same list. Ensure that the declaration of the single
3458 -- concurrent type precedes that of the item.
3460 elsif not In_Proper_Order
3461 (First
=> Encap_Decl
,
3462 Second
=> Item_Decl
)
3468 -- Otherwise both the item and the single concurrent type are
3469 -- in the same list. Ensure that the declaration of the single
3470 -- concurrent type precedes that of the item.
3472 elsif not In_Proper_Order
3473 (First
=> Encap_Decl
,
3474 Second
=> Item_Decl
)
3480 -- Otherwise the item and the single concurrent type reside within
3481 -- unrelated regions.
3484 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3486 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3487 & "immediately within the same region as single protected "
3488 & "type %"), Indic
, Item_Id
);
3492 -- At this point it is known that the Part_Of indicator is legal
3495 end Check_Part_Of_Concurrent_Type
;
3497 -- Start of processing for Analyze_Part_Of
3500 -- Assume that the indicator is illegal
3505 if Nkind_In
(Encap
, N_Expanded_Name
,
3507 N_Selected_Component
)
3510 Resolve_State
(Encap
);
3512 Encap_Id
:= Entity
(Encap
);
3514 -- The encapsulator is an abstract state
3516 if Ekind
(Encap_Id
) = E_Abstract_State
then
3519 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3521 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3524 -- Otherwise the encapsulator is not a legal choice
3528 ("indicator Part_Of must denote abstract state, single "
3529 & "protected type or single task type", Encap
);
3533 -- This is a syntax error, always report
3537 ("indicator Part_Of must denote abstract state, single protected "
3538 & "type or single task type", Encap
);
3542 -- Catch a case where indicator Part_Of denotes the abstract view of a
3543 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3545 if From_Limited_With
(Encap_Id
)
3546 and then Present
(Non_Limited_View
(Encap_Id
))
3547 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3549 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3550 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3554 -- The encapsulator is an abstract state
3556 if Ekind
(Encap_Id
) = E_Abstract_State
then
3557 Check_Part_Of_Abstract_State
;
3559 -- The encapsulator is a single concurrent type
3562 Check_Part_Of_Concurrent_Type
;
3564 end Analyze_Part_Of
;
3566 ----------------------------------
3567 -- Analyze_Part_Of_In_Decl_Part --
3568 ----------------------------------
3570 procedure Analyze_Part_Of_In_Decl_Part
3572 Freeze_Id
: Entity_Id
:= Empty
)
3574 Encap
: constant Node_Id
:=
3575 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3576 Errors
: constant Nat
:= Serious_Errors_Detected
;
3577 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3578 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3579 Constits
: Elist_Id
;
3580 Encap_Id
: Entity_Id
;
3584 -- Detect any discrepancies between the placement of the variable with
3585 -- respect to general state space and the encapsulating state or single
3592 Encap_Id
=> Encap_Id
,
3595 -- The Part_Of indicator turns the variable into a constituent of the
3596 -- encapsulating state or single concurrent type.
3599 pragma Assert
(Present
(Encap_Id
));
3600 Constits
:= Part_Of_Constituents
(Encap_Id
);
3602 if No
(Constits
) then
3603 Constits
:= New_Elmt_List
;
3604 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3607 Append_Elmt
(Var_Id
, Constits
);
3608 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3610 -- A Part_Of constituent partially refines an abstract state. This
3611 -- property does not apply to protected or task units.
3613 if Ekind
(Encap_Id
) = E_Abstract_State
then
3614 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3618 -- Emit a clarification message when the encapsulator is undefined,
3619 -- possibly due to contract freezing.
3621 if Errors
/= Serious_Errors_Detected
3622 and then Present
(Freeze_Id
)
3623 and then Has_Undefined_Reference
(Encap
)
3625 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3627 end Analyze_Part_Of_In_Decl_Part
;
3629 --------------------
3630 -- Analyze_Pragma --
3631 --------------------
3633 procedure Analyze_Pragma
(N
: Node_Id
) is
3634 Loc
: constant Source_Ptr
:= Sloc
(N
);
3636 Pname
: Name_Id
:= Pragma_Name
(N
);
3637 -- Name of the source pragma, or name of the corresponding aspect for
3638 -- pragmas which originate in a source aspect. In the latter case, the
3639 -- name may be different from the pragma name.
3641 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3643 Pragma_Exit
: exception;
3644 -- This exception is used to exit pragma processing completely. It
3645 -- is used when an error is detected, and no further processing is
3646 -- required. It is also used if an earlier error has left the tree in
3647 -- a state where the pragma should not be processed.
3650 -- Number of pragma argument associations
3656 -- First four pragma arguments (pragma argument association nodes, or
3657 -- Empty if the corresponding argument does not exist).
3659 type Name_List
is array (Natural range <>) of Name_Id
;
3660 type Args_List
is array (Natural range <>) of Node_Id
;
3661 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3663 -----------------------
3664 -- Local Subprograms --
3665 -----------------------
3667 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3668 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3669 -- get the given string argument, and place it in Name_Buffer, adding
3670 -- leading and trailing asterisks if they are not already present. The
3671 -- caller has already checked that Arg is a static string expression.
3673 procedure Ada_2005_Pragma
;
3674 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3675 -- Ada 95 mode, these are implementation defined pragmas, so should be
3676 -- caught by the No_Implementation_Pragmas restriction.
3678 procedure Ada_2012_Pragma
;
3679 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3680 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3681 -- should be caught by the No_Implementation_Pragmas restriction.
3683 procedure Analyze_Depends_Global
3684 (Spec_Id
: out Entity_Id
;
3685 Subp_Decl
: out Node_Id
;
3686 Legal
: out Boolean);
3687 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3688 -- legality of the placement and related context of the pragma. Spec_Id
3689 -- is the entity of the related subprogram. Subp_Decl is the declaration
3690 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3692 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3693 -- Inspect the remainder of the list containing pragma N and look for
3694 -- a pragma that matches Id. If found, analyze the pragma.
3696 procedure Analyze_Pre_Post_Condition
;
3697 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3699 procedure Analyze_Refined_Depends_Global_Post
3700 (Spec_Id
: out Entity_Id
;
3701 Body_Id
: out Entity_Id
;
3702 Legal
: out Boolean);
3703 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3704 -- Refined_Global and Refined_Post. Verify the legality of the placement
3705 -- and related context of the pragma. Spec_Id is the entity of the
3706 -- related subprogram. Body_Id is the entity of the subprogram body.
3707 -- Flag Legal is set when the pragma is legal.
3709 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3710 -- Perform full analysis of pragma Unmodified and the write aspect of
3711 -- pragma Unused. Flag Is_Unused should be set when verifying the
3712 -- semantics of pragma Unused.
3714 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3715 -- Perform full analysis of pragma Unreferenced and the read aspect of
3716 -- pragma Unused. Flag Is_Unused should be set when verifying the
3717 -- semantics of pragma Unused.
3719 procedure Check_Ada_83_Warning
;
3720 -- Issues a warning message for the current pragma if operating in Ada
3721 -- 83 mode (used for language pragmas that are not a standard part of
3722 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3725 procedure Check_Arg_Count
(Required
: Nat
);
3726 -- Check argument count for pragma is equal to given parameter. If not,
3727 -- then issue an error message and raise Pragma_Exit.
3729 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3730 -- Arg which can either be a pragma argument association, in which case
3731 -- the check is applied to the expression of the association or an
3732 -- expression directly.
3734 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3735 -- Check that an argument has the right form for an EXTERNAL_NAME
3736 -- parameter of an extended import/export pragma. The rule is that the
3737 -- name must be an identifier or string literal (in Ada 83 mode) or a
3738 -- static string expression (in Ada 95 mode).
3740 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3741 -- Check the specified argument Arg to make sure that it is an
3742 -- identifier. If not give error and raise Pragma_Exit.
3744 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3745 -- Check the specified argument Arg to make sure that it is an integer
3746 -- literal. If not give error and raise Pragma_Exit.
3748 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3749 -- Check the specified argument Arg to make sure that it has the proper
3750 -- syntactic form for a local name and meets the semantic requirements
3751 -- for a local name. The local name is analyzed as part of the
3752 -- processing for this call. In addition, the local name is required
3753 -- to represent an entity at the library level.
3755 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3756 -- Check the specified argument Arg to make sure that it has the proper
3757 -- syntactic form for a local name and meets the semantic requirements
3758 -- for a local name. The local name is analyzed as part of the
3759 -- processing for this call.
3761 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3762 -- Check the specified argument Arg to make sure that it is a valid
3763 -- locking policy name. If not give error and raise Pragma_Exit.
3765 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3766 -- Check the specified argument Arg to make sure that it is a valid
3767 -- elaboration policy name. If not give error and raise Pragma_Exit.
3769 procedure Check_Arg_Is_One_Of
3772 procedure Check_Arg_Is_One_Of
3774 N1
, N2
, N3
: Name_Id
);
3775 procedure Check_Arg_Is_One_Of
3777 N1
, N2
, N3
, N4
: Name_Id
);
3778 procedure Check_Arg_Is_One_Of
3780 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3781 -- Check the specified argument Arg to make sure that it is an
3782 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3783 -- present). If not then give error and raise Pragma_Exit.
3785 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3786 -- Check the specified argument Arg to make sure that it is a valid
3787 -- queuing policy name. If not give error and raise Pragma_Exit.
3789 procedure Check_Arg_Is_OK_Static_Expression
3791 Typ
: Entity_Id
:= Empty
);
3792 -- Check the specified argument Arg to make sure that it is a static
3793 -- expression of the given type (i.e. it will be analyzed and resolved
3794 -- using this type, which can be any valid argument to Resolve, e.g.
3795 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3796 -- Typ is left Empty, then any static expression is allowed. Includes
3797 -- checking that the argument does not raise Constraint_Error.
3799 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3800 -- Check the specified argument Arg to make sure that it is a valid task
3801 -- dispatching policy name. If not give error and raise Pragma_Exit.
3803 procedure Check_Arg_Order
(Names
: Name_List
);
3804 -- Checks for an instance of two arguments with identifiers for the
3805 -- current pragma which are not in the sequence indicated by Names,
3806 -- and if so, generates a fatal message about bad order of arguments.
3808 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3809 -- Check there are at least N arguments present
3811 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3812 -- Check there are no more than N arguments present
3814 procedure Check_Component
3817 In_Variant_Part
: Boolean := False);
3818 -- Examine an Unchecked_Union component for correct use of per-object
3819 -- constrained subtypes, and for restrictions on finalizable components.
3820 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3821 -- should be set when Comp comes from a record variant.
3823 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3824 -- Check if a rep item of the same name as the current pragma is already
3825 -- chained as a rep pragma to the given entity. If so give a message
3826 -- about the duplicate, and then raise Pragma_Exit so does not return.
3827 -- Note that if E is a type, then this routine avoids flagging a pragma
3828 -- which applies to a parent type from which E is derived.
3830 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3831 -- Nam is an N_String_Literal node containing the external name set by
3832 -- an Import or Export pragma (or extended Import or Export pragma).
3833 -- This procedure checks for possible duplications if this is the export
3834 -- case, and if found, issues an appropriate error message.
3836 procedure Check_Expr_Is_OK_Static_Expression
3838 Typ
: Entity_Id
:= Empty
);
3839 -- Check the specified expression Expr to make sure that it is a static
3840 -- expression of the given type (i.e. it will be analyzed and resolved
3841 -- using this type, which can be any valid argument to Resolve, e.g.
3842 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3843 -- Typ is left Empty, then any static expression is allowed. Includes
3844 -- checking that the expression does not raise Constraint_Error.
3846 procedure Check_First_Subtype
(Arg
: Node_Id
);
3847 -- Checks that Arg, whose expression is an entity name, references a
3850 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3851 -- Checks that the given argument has an identifier, and if so, requires
3852 -- it to match the given identifier name. If there is no identifier, or
3853 -- a non-matching identifier, then an error message is given and
3854 -- Pragma_Exit is raised.
3856 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3857 -- Checks that the given argument has an identifier, and if so, requires
3858 -- it to match one of the given identifier names. If there is no
3859 -- identifier, or a non-matching identifier, then an error message is
3860 -- given and Pragma_Exit is raised.
3862 procedure Check_In_Main_Program
;
3863 -- Common checks for pragmas that appear within a main program
3864 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3866 procedure Check_Interrupt_Or_Attach_Handler
;
3867 -- Common processing for first argument of pragma Interrupt_Handler or
3868 -- pragma Attach_Handler.
3870 procedure Check_Loop_Pragma_Placement
;
3871 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3872 -- appear immediately within a construct restricted to loops, and that
3873 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3875 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3876 -- Check that pragma appears in a declarative part, or in a package
3877 -- specification, i.e. that it does not occur in a statement sequence
3880 procedure Check_No_Identifier
(Arg
: Node_Id
);
3881 -- Checks that the given argument does not have an identifier. If
3882 -- an identifier is present, then an error message is issued, and
3883 -- Pragma_Exit is raised.
3885 procedure Check_No_Identifiers
;
3886 -- Checks that none of the arguments to the pragma has an identifier.
3887 -- If any argument has an identifier, then an error message is issued,
3888 -- and Pragma_Exit is raised.
3890 procedure Check_No_Link_Name
;
3891 -- Checks that no link name is specified
3893 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3894 -- Checks if the given argument has an identifier, and if so, requires
3895 -- it to match the given identifier name. If there is a non-matching
3896 -- identifier, then an error message is given and Pragma_Exit is raised.
3898 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3899 -- Checks if the given argument has an identifier, and if so, requires
3900 -- it to match the given identifier name. If there is a non-matching
3901 -- identifier, then an error message is given and Pragma_Exit is raised.
3902 -- In this version of the procedure, the identifier name is given as
3903 -- a string with lower case letters.
3905 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3906 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3907 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3908 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3909 -- is an OK static boolean expression. Emit an error if this is not the
3912 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3913 -- Constr is a constraint from an N_Subtype_Indication node from a
3914 -- component constraint in an Unchecked_Union type. This routine checks
3915 -- that the constraint is static as required by the restrictions for
3918 procedure Check_Valid_Configuration_Pragma
;
3919 -- Legality checks for placement of a configuration pragma
3921 procedure Check_Valid_Library_Unit_Pragma
;
3922 -- Legality checks for library unit pragmas. A special case arises for
3923 -- pragmas in generic instances that come from copies of the original
3924 -- library unit pragmas in the generic templates. In the case of other
3925 -- than library level instantiations these can appear in contexts which
3926 -- would normally be invalid (they only apply to the original template
3927 -- and to library level instantiations), and they are simply ignored,
3928 -- which is implemented by rewriting them as null statements.
3930 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3931 -- Check an Unchecked_Union variant for lack of nested variants and
3932 -- presence of at least one component. UU_Typ is the related Unchecked_
3935 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3936 -- Subsidiary routine to the processing of pragmas Abstract_State,
3937 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3938 -- Refined_Global and Refined_State. Transform argument Arg into
3939 -- an aggregate if not one already. N_Null is never transformed.
3940 -- Arg may denote an aspect specification or a pragma argument
3943 procedure Error_Pragma
(Msg
: String);
3944 pragma No_Return
(Error_Pragma
);
3945 -- Outputs error message for current pragma. The message contains a %
3946 -- that will be replaced with the pragma name, and the flag is placed
3947 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3948 -- calls Fix_Error (see spec of that procedure for details).
3950 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3951 pragma No_Return
(Error_Pragma_Arg
);
3952 -- Outputs error message for current pragma. The message may contain
3953 -- a % that will be replaced with the pragma name. The parameter Arg
3954 -- may either be a pragma argument association, in which case the flag
3955 -- is placed on the expression of this association, or an expression,
3956 -- in which case the flag is placed directly on the expression. The
3957 -- message is placed using Error_Msg_N, so the message may also contain
3958 -- an & insertion character which will reference the given Arg value.
3959 -- After placing the message, Pragma_Exit is raised. Note: this routine
3960 -- calls Fix_Error (see spec of that procedure for details).
3962 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3963 pragma No_Return
(Error_Pragma_Arg
);
3964 -- Similar to above form of Error_Pragma_Arg except that two messages
3965 -- are provided, the second is a continuation comment starting with \.
3967 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3968 pragma No_Return
(Error_Pragma_Arg_Ident
);
3969 -- Outputs error message for current pragma. The message may contain a %
3970 -- that will be replaced with the pragma name. The parameter Arg must be
3971 -- a pragma argument association with a non-empty identifier (i.e. its
3972 -- Chars field must be set), and the error message is placed on the
3973 -- identifier. The message is placed using Error_Msg_N so the message
3974 -- may also contain an & insertion character which will reference
3975 -- the identifier. After placing the message, Pragma_Exit is raised.
3976 -- Note: this routine calls Fix_Error (see spec of that procedure for
3979 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3980 pragma No_Return
(Error_Pragma_Ref
);
3981 -- Outputs error message for current pragma. The message may contain
3982 -- a % that will be replaced with the pragma name. The parameter Ref
3983 -- must be an entity whose name can be referenced by & and sloc by #.
3984 -- After placing the message, Pragma_Exit is raised. Note: this routine
3985 -- calls Fix_Error (see spec of that procedure for details).
3987 function Find_Lib_Unit_Name
return Entity_Id
;
3988 -- Used for a library unit pragma to find the entity to which the
3989 -- library unit pragma applies, returns the entity found.
3991 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3992 -- If the pragma is a compilation unit pragma, the id must denote the
3993 -- compilation unit in the same compilation, and the pragma must appear
3994 -- in the list of preceding or trailing pragmas. If it is a program
3995 -- unit pragma that is not a compilation unit pragma, then the
3996 -- identifier must be visible.
3998 function Find_Unique_Parameterless_Procedure
4000 Arg
: Node_Id
) return Entity_Id
;
4001 -- Used for a procedure pragma to find the unique parameterless
4002 -- procedure identified by Name, returns it if it exists, otherwise
4003 -- errors out and uses Arg as the pragma argument for the message.
4005 function Fix_Error
(Msg
: String) return String;
4006 -- This is called prior to issuing an error message. Msg is the normal
4007 -- error message issued in the pragma case. This routine checks for the
4008 -- case of a pragma coming from an aspect in the source, and returns a
4009 -- message suitable for the aspect case as follows:
4011 -- Each substring "pragma" is replaced by "aspect"
4013 -- If "argument of" is at the start of the error message text, it is
4014 -- replaced by "entity for".
4016 -- If "argument" is at the start of the error message text, it is
4017 -- replaced by "entity".
4019 -- So for example, "argument of pragma X must be discrete type"
4020 -- returns "entity for aspect X must be a discrete type".
4022 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4023 -- be different from the pragma name). If the current pragma results
4024 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4025 -- original pragma name.
4027 procedure Gather_Associations
4029 Args
: out Args_List
);
4030 -- This procedure is used to gather the arguments for a pragma that
4031 -- permits arbitrary ordering of parameters using the normal rules
4032 -- for named and positional parameters. The Names argument is a list
4033 -- of Name_Id values that corresponds to the allowed pragma argument
4034 -- association identifiers in order. The result returned in Args is
4035 -- a list of corresponding expressions that are the pragma arguments.
4036 -- Note that this is a list of expressions, not of pragma argument
4037 -- associations (Gather_Associations has completely checked all the
4038 -- optional identifiers when it returns). An entry in Args is Empty
4039 -- on return if the corresponding argument is not present.
4041 procedure GNAT_Pragma
;
4042 -- Called for all GNAT defined pragmas to check the relevant restriction
4043 -- (No_Implementation_Pragmas).
4045 function Is_Before_First_Decl
4046 (Pragma_Node
: Node_Id
;
4047 Decls
: List_Id
) return Boolean;
4048 -- Return True if Pragma_Node is before the first declarative item in
4049 -- Decls where Decls is the list of declarative items.
4051 function Is_Configuration_Pragma
return Boolean;
4052 -- Determines if the placement of the current pragma is appropriate
4053 -- for a configuration pragma.
4055 function Is_In_Context_Clause
return Boolean;
4056 -- Returns True if pragma appears within the context clause of a unit,
4057 -- and False for any other placement (does not generate any messages).
4059 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4060 -- Analyzes the argument, and determines if it is a static string
4061 -- expression, returns True if so, False if non-static or not String.
4062 -- A special case is that a string literal returns True in Ada 83 mode
4063 -- (which has no such thing as static string expressions). Note that
4064 -- the call analyzes its argument, so this cannot be used for the case
4065 -- where an identifier might not be declared.
4067 procedure Pragma_Misplaced
;
4068 pragma No_Return
(Pragma_Misplaced
);
4069 -- Issue fatal error message for misplaced pragma
4071 procedure Process_Atomic_Independent_Shared_Volatile
;
4072 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4073 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4074 -- and treated as being identical in effect to pragma Atomic.
4076 procedure Process_Compile_Time_Warning_Or_Error
;
4077 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4079 procedure Process_Convention
4080 (C
: out Convention_Id
;
4081 Ent
: out Entity_Id
);
4082 -- Common processing for Convention, Interface, Import and Export.
4083 -- Checks first two arguments of pragma, and sets the appropriate
4084 -- convention value in the specified entity or entities. On return
4085 -- C is the convention, Ent is the referenced entity.
4087 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4088 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4089 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4091 procedure Process_Extended_Import_Export_Object_Pragma
4092 (Arg_Internal
: Node_Id
;
4093 Arg_External
: Node_Id
;
4094 Arg_Size
: Node_Id
);
4095 -- Common processing for the pragmas Import/Export_Object. The three
4096 -- arguments correspond to the three named parameters of the pragmas. An
4097 -- argument is empty if the corresponding parameter is not present in
4100 procedure Process_Extended_Import_Export_Internal_Arg
4101 (Arg_Internal
: Node_Id
:= Empty
);
4102 -- Common processing for all extended Import and Export pragmas. The
4103 -- argument is the pragma parameter for the Internal argument. If
4104 -- Arg_Internal is empty or inappropriate, an error message is posted.
4105 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4106 -- set to identify the referenced entity.
4108 procedure Process_Extended_Import_Export_Subprogram_Pragma
4109 (Arg_Internal
: Node_Id
;
4110 Arg_External
: Node_Id
;
4111 Arg_Parameter_Types
: Node_Id
;
4112 Arg_Result_Type
: Node_Id
:= Empty
;
4113 Arg_Mechanism
: Node_Id
;
4114 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4115 -- Common processing for all extended Import and Export pragmas applying
4116 -- to subprograms. The caller omits any arguments that do not apply to
4117 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4118 -- only in the Import_Function and Export_Function cases). The argument
4119 -- names correspond to the allowed pragma association identifiers.
4121 procedure Process_Generic_List
;
4122 -- Common processing for Share_Generic and Inline_Generic
4124 procedure Process_Import_Or_Interface
;
4125 -- Common processing for Import or Interface
4127 procedure Process_Import_Predefined_Type
;
4128 -- Processing for completing a type with pragma Import. This is used
4129 -- to declare types that match predefined C types, especially for cases
4130 -- without corresponding Ada predefined type.
4132 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4133 -- Inline status of a subprogram, indicated as follows:
4134 -- Suppressed: inlining is suppressed for the subprogram
4135 -- Disabled: no inlining is requested for the subprogram
4136 -- Enabled: inlining is requested/required for the subprogram
4138 procedure Process_Inline
(Status
: Inline_Status
);
4139 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4140 -- indicates the inline status specified by the pragma.
4142 procedure Process_Interface_Name
4143 (Subprogram_Def
: Entity_Id
;
4147 -- Given the last two arguments of pragma Import, pragma Export, or
4148 -- pragma Interface_Name, performs validity checks and sets the
4149 -- Interface_Name field of the given subprogram entity to the
4150 -- appropriate external or link name, depending on the arguments given.
4151 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4152 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4153 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4154 -- nor Link_Arg is present, the interface name is set to the default
4155 -- from the subprogram name. In addition, the pragma itself is passed
4156 -- to analyze any expressions in the case the pragma came from an aspect
4159 procedure Process_Interrupt_Or_Attach_Handler
;
4160 -- Common processing for Interrupt and Attach_Handler pragmas
4162 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4163 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4164 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4165 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4166 -- is not set in the Restrictions case.
4168 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4169 -- Common processing for Suppress and Unsuppress. The boolean parameter
4170 -- Suppress_Case is True for the Suppress case, and False for the
4173 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4174 -- Subsidiary to the analysis of pragmas Independent[_Components].
4175 -- Record such a pragma N applied to entity E for future checks.
4177 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4178 -- This procedure sets the Is_Exported flag for the given entity,
4179 -- checking that the entity was not previously imported. Arg is
4180 -- the argument that specified the entity. A check is also made
4181 -- for exporting inappropriate entities.
4183 procedure Set_Extended_Import_Export_External_Name
4184 (Internal_Ent
: Entity_Id
;
4185 Arg_External
: Node_Id
);
4186 -- Common processing for all extended import export pragmas. The first
4187 -- argument, Internal_Ent, is the internal entity, which has already
4188 -- been checked for validity by the caller. Arg_External is from the
4189 -- Import or Export pragma, and may be null if no External parameter
4190 -- was present. If Arg_External is present and is a non-null string
4191 -- (a null string is treated as the default), then the Interface_Name
4192 -- field of Internal_Ent is set appropriately.
4194 procedure Set_Imported
(E
: Entity_Id
);
4195 -- This procedure sets the Is_Imported flag for the given entity,
4196 -- checking that it is not previously exported or imported.
4198 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4199 -- Mech is a parameter passing mechanism (see Import_Function syntax
4200 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4201 -- has the right form, and if not issues an error message. If the
4202 -- argument has the right form then the Mechanism field of Ent is
4203 -- set appropriately.
4205 procedure Set_Rational_Profile
;
4206 -- Activate the set of configuration pragmas and permissions that make
4207 -- up the Rational profile.
4209 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4210 -- Activate the set of configuration pragmas and restrictions that make
4211 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4212 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4213 -- which is used for error messages on any constructs violating the
4216 ----------------------------------
4217 -- Acquire_Warning_Match_String --
4218 ----------------------------------
4220 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4222 String_To_Name_Buffer
4223 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4225 -- Add asterisk at start if not already there
4227 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4228 Name_Buffer
(2 .. Name_Len
+ 1) :=
4229 Name_Buffer
(1 .. Name_Len
);
4230 Name_Buffer
(1) := '*';
4231 Name_Len
:= Name_Len
+ 1;
4234 -- Add asterisk at end if not already there
4236 if Name_Buffer
(Name_Len
) /= '*' then
4237 Name_Len
:= Name_Len
+ 1;
4238 Name_Buffer
(Name_Len
) := '*';
4240 end Acquire_Warning_Match_String
;
4242 ---------------------
4243 -- Ada_2005_Pragma --
4244 ---------------------
4246 procedure Ada_2005_Pragma
is
4248 if Ada_Version
<= Ada_95
then
4249 Check_Restriction
(No_Implementation_Pragmas
, N
);
4251 end Ada_2005_Pragma
;
4253 ---------------------
4254 -- Ada_2012_Pragma --
4255 ---------------------
4257 procedure Ada_2012_Pragma
is
4259 if Ada_Version
<= Ada_2005
then
4260 Check_Restriction
(No_Implementation_Pragmas
, N
);
4262 end Ada_2012_Pragma
;
4264 ----------------------------
4265 -- Analyze_Depends_Global --
4266 ----------------------------
4268 procedure Analyze_Depends_Global
4269 (Spec_Id
: out Entity_Id
;
4270 Subp_Decl
: out Node_Id
;
4271 Legal
: out Boolean)
4274 -- Assume that the pragma is illegal
4281 Check_Arg_Count
(1);
4283 -- Ensure the proper placement of the pragma. Depends/Global must be
4284 -- associated with a subprogram declaration or a body that acts as a
4287 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4291 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4294 -- Generic subprogram
4296 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4299 -- Object declaration of a single concurrent type
4301 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4302 and then Is_Single_Concurrent_Object
4303 (Unique_Defining_Entity
(Subp_Decl
))
4309 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4312 -- Subprogram body acts as spec
4314 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4315 and then No
(Corresponding_Spec
(Subp_Decl
))
4319 -- Subprogram body stub acts as spec
4321 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4322 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4326 -- Subprogram declaration
4328 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4333 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4341 -- If we get here, then the pragma is legal
4344 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4346 -- When the related context is an entry, the entry must belong to a
4347 -- protected unit (SPARK RM 6.1.4(6)).
4349 if Is_Entry_Declaration
(Spec_Id
)
4350 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4355 -- When the related context is an anonymous object created for a
4356 -- simple concurrent type, the type must be a task
4357 -- (SPARK RM 6.1.4(6)).
4359 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4360 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4366 -- A pragma that applies to a Ghost entity becomes Ghost for the
4367 -- purposes of legality checks and removal of ignored Ghost code.
4369 Mark_Ghost_Pragma
(N
, Spec_Id
);
4370 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4371 end Analyze_Depends_Global
;
4373 ------------------------
4374 -- Analyze_If_Present --
4375 ------------------------
4377 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4381 pragma Assert
(Is_List_Member
(N
));
4383 -- Inspect the declarations or statements following pragma N looking
4384 -- for another pragma whose Id matches the caller's request. If it is
4385 -- available, analyze it.
4388 while Present
(Stmt
) loop
4389 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4390 Analyze_Pragma
(Stmt
);
4393 -- The first source declaration or statement immediately following
4394 -- N ends the region where a pragma may appear.
4396 elsif Comes_From_Source
(Stmt
) then
4402 end Analyze_If_Present
;
4404 --------------------------------
4405 -- Analyze_Pre_Post_Condition --
4406 --------------------------------
4408 procedure Analyze_Pre_Post_Condition
is
4409 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4410 Subp_Decl
: Node_Id
;
4411 Subp_Id
: Entity_Id
;
4413 Duplicates_OK
: Boolean := False;
4414 -- Flag set when a pre/postcondition allows multiple pragmas of the
4417 In_Body_OK
: Boolean := False;
4418 -- Flag set when a pre/postcondition is allowed to appear on a body
4419 -- even though the subprogram may have a spec.
4421 Is_Pre_Post
: Boolean := False;
4422 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4425 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4426 -- Implement rules in AI12-0131: an overriding operation can have
4427 -- a class-wide precondition only if one of its ancestors has an
4428 -- explicit class-wide precondition.
4430 -----------------------------
4431 -- Inherits_Class_Wide_Pre --
4432 -----------------------------
4434 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4435 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4438 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4441 -- Check ancestors on the overriding operation to examine the
4442 -- preconditions that may apply to them.
4444 while Present
(Prev
) loop
4445 Cont
:= Contract
(Prev
);
4446 if Present
(Cont
) then
4447 Prag
:= Pre_Post_Conditions
(Cont
);
4448 while Present
(Prag
) loop
4449 if Pragma_Name
(Prag
) = Name_Precondition
4450 and then Class_Present
(Prag
)
4455 Prag
:= Next_Pragma
(Prag
);
4459 -- For a type derived from a generic formal type, the operation
4460 -- inheriting the condition is a renaming, not an overriding of
4461 -- the operation of the formal. Ditto for an inherited
4462 -- operation which has no explicit contracts.
4464 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4465 or else not Comes_From_Source
(Prev
)
4467 Prev
:= Alias
(Prev
);
4469 Prev
:= Overridden_Operation
(Prev
);
4473 -- If the controlling type of the subprogram has progenitors, an
4474 -- interface operation implemented by the current operation may
4475 -- have a class-wide precondition.
4477 if Has_Interfaces
(Typ
) then
4482 Prim_Elmt
: Elmt_Id
;
4483 Prim_List
: Elist_Id
;
4486 Collect_Interfaces
(Typ
, Ints
);
4487 Elmt
:= First_Elmt
(Ints
);
4489 -- Iterate over the primitive operations of each interface
4491 while Present
(Elmt
) loop
4492 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4493 Prim_Elmt
:= First_Elmt
(Prim_List
);
4494 while Present
(Prim_Elmt
) loop
4495 Prim
:= Node
(Prim_Elmt
);
4496 if Chars
(Prim
) = Chars
(E
)
4497 and then Present
(Contract
(Prim
))
4498 and then Class_Present
4499 (Pre_Post_Conditions
(Contract
(Prim
)))
4504 Next_Elmt
(Prim_Elmt
);
4513 end Inherits_Class_Wide_Pre
;
4515 -- Start of processing for Analyze_Pre_Post_Condition
4518 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4519 -- offer uniformity among the various kinds of pre/postconditions by
4520 -- rewriting the pragma identifier. This allows the retrieval of the
4521 -- original pragma name by routine Original_Aspect_Pragma_Name.
4523 if Comes_From_Source
(N
) then
4524 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4525 Is_Pre_Post
:= True;
4526 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4527 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4529 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4530 Is_Pre_Post
:= True;
4531 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4532 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4536 -- Determine the semantics with respect to duplicates and placement
4537 -- in a body. Pragmas Precondition and Postcondition were introduced
4538 -- before aspects and are not subject to the same aspect-like rules.
4540 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4541 Duplicates_OK
:= True;
4547 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4548 -- argument without an identifier.
4551 Check_Arg_Count
(1);
4552 Check_No_Identifiers
;
4554 -- Pragmas Precondition and Postcondition have complex argument
4558 Check_At_Least_N_Arguments
(1);
4559 Check_At_Most_N_Arguments
(2);
4560 Check_Optional_Identifier
(Arg1
, Name_Check
);
4562 if Present
(Arg2
) then
4563 Check_Optional_Identifier
(Arg2
, Name_Message
);
4564 Preanalyze_Spec_Expression
4565 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4569 -- For a pragma PPC in the extended main source unit, record enabled
4571 -- ??? nothing checks that the pragma is in the main source unit
4573 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4574 Set_SCO_Pragma_Enabled
(Loc
);
4577 -- Ensure the proper placement of the pragma
4580 Find_Related_Declaration_Or_Body
4581 (N
, Do_Checks
=> not Duplicates_OK
);
4583 -- When a pre/postcondition pragma applies to an abstract subprogram,
4584 -- its original form must be an aspect with 'Class.
4586 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4587 if not From_Aspect_Specification
(N
) then
4589 ("pragma % cannot be applied to abstract subprogram");
4591 elsif not Class_Present
(N
) then
4593 ("aspect % requires ''Class for abstract subprogram");
4596 -- Entry declaration
4598 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4601 -- Generic subprogram declaration
4603 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4608 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4609 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4613 -- Subprogram body stub
4615 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4616 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4620 -- Subprogram declaration
4622 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4624 -- AI05-0230: When a pre/postcondition pragma applies to a null
4625 -- procedure, its original form must be an aspect with 'Class.
4627 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4628 and then Null_Present
(Specification
(Subp_Decl
))
4629 and then From_Aspect_Specification
(N
)
4630 and then not Class_Present
(N
)
4632 Error_Pragma
("aspect % requires ''Class for null procedure");
4635 -- Implement the legality checks mandated by AI12-0131:
4636 -- Pre'Class shall not be specified for an overriding primitive
4637 -- subprogram of a tagged type T unless the Pre'Class aspect is
4638 -- specified for the corresponding primitive subprogram of some
4642 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4645 if Class_Present
(N
)
4646 and then Pragma_Name
(N
) = Name_Precondition
4647 and then Present
(Overridden_Operation
(E
))
4648 and then not Inherits_Class_Wide_Pre
(E
)
4651 ("illegal class-wide precondition on overriding operation",
4652 Corresponding_Aspect
(N
));
4656 -- A renaming declaration may inherit a generated pragma, its
4657 -- placement comes from expansion, not from source.
4659 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4660 and then not Comes_From_Source
(N
)
4664 -- Otherwise the placement is illegal
4671 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4673 -- A pragma that applies to a Ghost entity becomes Ghost for the
4674 -- purposes of legality checks and removal of ignored Ghost code.
4676 Mark_Ghost_Pragma
(N
, Subp_Id
);
4678 -- Chain the pragma on the contract for further processing by
4679 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4681 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4683 -- Fully analyze the pragma when it appears inside an entry or
4684 -- subprogram body because it cannot benefit from forward references.
4686 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4688 N_Subprogram_Body_Stub
)
4690 -- The legality checks of pragmas Precondition and Postcondition
4691 -- are affected by the SPARK mode in effect and the volatility of
4692 -- the context. Analyze all pragmas in a specific order.
4694 Analyze_If_Present
(Pragma_SPARK_Mode
);
4695 Analyze_If_Present
(Pragma_Volatile_Function
);
4696 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4698 end Analyze_Pre_Post_Condition
;
4700 -----------------------------------------
4701 -- Analyze_Refined_Depends_Global_Post --
4702 -----------------------------------------
4704 procedure Analyze_Refined_Depends_Global_Post
4705 (Spec_Id
: out Entity_Id
;
4706 Body_Id
: out Entity_Id
;
4707 Legal
: out Boolean)
4709 Body_Decl
: Node_Id
;
4710 Spec_Decl
: Node_Id
;
4713 -- Assume that the pragma is illegal
4720 Check_Arg_Count
(1);
4721 Check_No_Identifiers
;
4723 -- Verify the placement of the pragma and check for duplicates. The
4724 -- pragma must apply to a subprogram body [stub].
4726 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4728 if not Nkind_In
(Body_Decl
, N_Entry_Body
,
4730 N_Subprogram_Body_Stub
,
4738 Body_Id
:= Defining_Entity
(Body_Decl
);
4739 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4741 -- The pragma must apply to the second declaration of a subprogram.
4742 -- In other words, the body [stub] cannot acts as a spec.
4744 if No
(Spec_Id
) then
4745 Error_Pragma
("pragma % cannot apply to a stand alone body");
4748 -- Catch the case where the subprogram body is a subunit and acts as
4749 -- the third declaration of the subprogram.
4751 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4752 Error_Pragma
("pragma % cannot apply to a subunit");
4756 -- A refined pragma can only apply to the body [stub] of a subprogram
4757 -- declared in the visible part of a package. Retrieve the context of
4758 -- the subprogram declaration.
4760 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4762 -- When dealing with protected entries or protected subprograms, use
4763 -- the enclosing protected type as the proper context.
4765 if Ekind_In
(Spec_Id
, E_Entry
,
4769 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4771 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4774 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4776 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4777 & "subprogram declared in a package specification"));
4781 -- If we get here, then the pragma is legal
4785 -- A pragma that applies to a Ghost entity becomes Ghost for the
4786 -- purposes of legality checks and removal of ignored Ghost code.
4788 Mark_Ghost_Pragma
(N
, Spec_Id
);
4790 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4791 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4793 end Analyze_Refined_Depends_Global_Post
;
4795 ----------------------------------
4796 -- Analyze_Unmodified_Or_Unused --
4797 ----------------------------------
4799 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4804 Ghost_Error_Posted
: Boolean := False;
4805 -- Flag set when an error concerning the illegal mix of Ghost and
4806 -- non-Ghost variables is emitted.
4808 Ghost_Id
: Entity_Id
:= Empty
;
4809 -- The entity of the first Ghost variable encountered while
4810 -- processing the arguments of the pragma.
4814 Check_At_Least_N_Arguments
(1);
4816 -- Loop through arguments
4819 while Present
(Arg
) loop
4820 Check_No_Identifier
(Arg
);
4822 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4823 -- in fact generate reference, so that the entity will have a
4824 -- reference, which will inhibit any warnings about it not
4825 -- being referenced, and also properly show up in the ali file
4826 -- as a reference. But this reference is recorded before the
4827 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4828 -- generated for this reference.
4830 Check_Arg_Is_Local_Name
(Arg
);
4831 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4833 if Is_Entity_Name
(Arg_Expr
) then
4834 Arg_Id
:= Entity
(Arg_Expr
);
4836 -- Skip processing the argument if already flagged
4838 if Is_Assignable
(Arg_Id
)
4839 and then not Has_Pragma_Unmodified
(Arg_Id
)
4840 and then not Has_Pragma_Unused
(Arg_Id
)
4842 Set_Has_Pragma_Unmodified
(Arg_Id
);
4845 Set_Has_Pragma_Unused
(Arg_Id
);
4848 -- A pragma that applies to a Ghost entity becomes Ghost for
4849 -- the purposes of legality checks and removal of ignored
4852 Mark_Ghost_Pragma
(N
, Arg_Id
);
4854 -- Capture the entity of the first Ghost variable being
4855 -- processed for error detection purposes.
4857 if Is_Ghost_Entity
(Arg_Id
) then
4858 if No
(Ghost_Id
) then
4862 -- Otherwise the variable is non-Ghost. It is illegal to mix
4863 -- references to Ghost and non-Ghost entities
4866 elsif Present
(Ghost_Id
)
4867 and then not Ghost_Error_Posted
4869 Ghost_Error_Posted
:= True;
4871 Error_Msg_Name_1
:= Pname
;
4873 ("pragma % cannot mention ghost and non-ghost "
4876 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4877 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4879 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4880 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4883 -- Warn if already flagged as Unused or Unmodified
4885 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4886 if Has_Pragma_Unused
(Arg_Id
) then
4888 ("??pragma Unused already given for &!", Arg_Expr
,
4892 ("??pragma Unmodified already given for &!", Arg_Expr
,
4896 -- Otherwise the pragma referenced an illegal entity
4900 ("pragma% can only be applied to a variable", Arg_Expr
);
4906 end Analyze_Unmodified_Or_Unused
;
4908 ------------------------------------
4909 -- Analyze_Unreferenced_Or_Unused --
4910 ------------------------------------
4912 procedure Analyze_Unreferenced_Or_Unused
4913 (Is_Unused
: Boolean := False)
4920 Ghost_Error_Posted
: Boolean := False;
4921 -- Flag set when an error concerning the illegal mix of Ghost and
4922 -- non-Ghost names is emitted.
4924 Ghost_Id
: Entity_Id
:= Empty
;
4925 -- The entity of the first Ghost name encountered while processing
4926 -- the arguments of the pragma.
4930 Check_At_Least_N_Arguments
(1);
4932 -- Check case of appearing within context clause
4934 if not Is_Unused
and then Is_In_Context_Clause
then
4936 -- The arguments must all be units mentioned in a with clause in
4937 -- the same context clause. Note that Par.Prag already checked
4938 -- that the arguments are either identifiers or selected
4942 while Present
(Arg
) loop
4943 Citem
:= First
(List_Containing
(N
));
4944 while Citem
/= N
loop
4945 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4947 if Nkind
(Citem
) = N_With_Clause
4948 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4950 Set_Has_Pragma_Unreferenced
4953 (Library_Unit
(Citem
))));
4954 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4963 ("argument of pragma% is not withed unit", Arg
);
4969 -- Case of not in list of context items
4973 while Present
(Arg
) loop
4974 Check_No_Identifier
(Arg
);
4976 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4977 -- in fact generate reference, so that the entity will have a
4978 -- reference, which will inhibit any warnings about it not
4979 -- being referenced, and also properly show up in the ali file
4980 -- as a reference. But this reference is recorded before the
4981 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4982 -- generated for this reference.
4984 Check_Arg_Is_Local_Name
(Arg
);
4985 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4987 if Is_Entity_Name
(Arg_Expr
) then
4988 Arg_Id
:= Entity
(Arg_Expr
);
4990 -- Warn if already flagged as Unused or Unreferenced and
4991 -- skip processing the argument.
4993 if Has_Pragma_Unreferenced
(Arg_Id
) then
4994 if Has_Pragma_Unused
(Arg_Id
) then
4996 ("??pragma Unused already given for &!", Arg_Expr
,
5000 ("??pragma Unreferenced already given for &!",
5004 -- Apply Unreferenced to the entity
5007 -- If the entity is overloaded, the pragma applies to the
5008 -- most recent overloading, as documented. In this case,
5009 -- name resolution does not generate a reference, so it
5010 -- must be done here explicitly.
5012 if Is_Overloaded
(Arg_Expr
) then
5013 Generate_Reference
(Arg_Id
, N
);
5016 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5019 Set_Has_Pragma_Unused
(Arg_Id
);
5022 -- A pragma that applies to a Ghost entity becomes Ghost
5023 -- for the purposes of legality checks and removal of
5024 -- ignored Ghost code.
5026 Mark_Ghost_Pragma
(N
, Arg_Id
);
5028 -- Capture the entity of the first Ghost name being
5029 -- processed for error detection purposes.
5031 if Is_Ghost_Entity
(Arg_Id
) then
5032 if No
(Ghost_Id
) then
5036 -- Otherwise the name is non-Ghost. It is illegal to mix
5037 -- references to Ghost and non-Ghost entities
5040 elsif Present
(Ghost_Id
)
5041 and then not Ghost_Error_Posted
5043 Ghost_Error_Posted
:= True;
5045 Error_Msg_Name_1
:= Pname
;
5047 ("pragma % cannot mention ghost and non-ghost "
5050 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5052 ("\& # declared as ghost", N
, Ghost_Id
);
5054 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5056 ("\& # declared as non-ghost", N
, Arg_Id
);
5064 end Analyze_Unreferenced_Or_Unused
;
5066 --------------------------
5067 -- Check_Ada_83_Warning --
5068 --------------------------
5070 procedure Check_Ada_83_Warning
is
5072 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5073 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5075 end Check_Ada_83_Warning
;
5077 ---------------------
5078 -- Check_Arg_Count --
5079 ---------------------
5081 procedure Check_Arg_Count
(Required
: Nat
) is
5083 if Arg_Count
/= Required
then
5084 Error_Pragma
("wrong number of arguments for pragma%");
5086 end Check_Arg_Count
;
5088 --------------------------------
5089 -- Check_Arg_Is_External_Name --
5090 --------------------------------
5092 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5093 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5096 if Nkind
(Argx
) = N_Identifier
then
5100 Analyze_And_Resolve
(Argx
, Standard_String
);
5102 if Is_OK_Static_Expression
(Argx
) then
5105 elsif Etype
(Argx
) = Any_Type
then
5108 -- An interesting special case, if we have a string literal and
5109 -- we are in Ada 83 mode, then we allow it even though it will
5110 -- not be flagged as static. This allows expected Ada 83 mode
5111 -- use of external names which are string literals, even though
5112 -- technically these are not static in Ada 83.
5114 elsif Ada_Version
= Ada_83
5115 and then Nkind
(Argx
) = N_String_Literal
5119 -- Here we have a real error (non-static expression)
5122 Error_Msg_Name_1
:= Pname
;
5123 Flag_Non_Static_Expr
5124 (Fix_Error
("argument for pragma% must be a identifier or "
5125 & "static string expression!"), Argx
);
5130 end Check_Arg_Is_External_Name
;
5132 -----------------------------
5133 -- Check_Arg_Is_Identifier --
5134 -----------------------------
5136 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5137 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5139 if Nkind
(Argx
) /= N_Identifier
then
5140 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5142 end Check_Arg_Is_Identifier
;
5144 ----------------------------------
5145 -- Check_Arg_Is_Integer_Literal --
5146 ----------------------------------
5148 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5149 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5151 if Nkind
(Argx
) /= N_Integer_Literal
then
5153 ("argument for pragma% must be integer literal", Argx
);
5155 end Check_Arg_Is_Integer_Literal
;
5157 -------------------------------------------
5158 -- Check_Arg_Is_Library_Level_Local_Name --
5159 -------------------------------------------
5163 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5164 -- | library_unit_NAME
5166 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5168 Check_Arg_Is_Local_Name
(Arg
);
5170 -- If it came from an aspect, we want to give the error just as if it
5171 -- came from source.
5173 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5174 and then (Comes_From_Source
(N
)
5175 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5178 ("argument for pragma% must be library level entity", Arg
);
5180 end Check_Arg_Is_Library_Level_Local_Name
;
5182 -----------------------------
5183 -- Check_Arg_Is_Local_Name --
5184 -----------------------------
5188 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5189 -- | library_unit_NAME
5191 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5192 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5195 -- If this pragma came from an aspect specification, we don't want to
5196 -- check for this error, because that would cause spurious errors, in
5197 -- case a type is frozen in a scope more nested than the type. The
5198 -- aspect itself of course can't be anywhere but on the declaration
5201 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5202 if From_Aspect_Specification
(Parent
(Arg
)) then
5206 -- Arg is the Expression of an N_Pragma_Argument_Association
5209 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5216 if Nkind
(Argx
) not in N_Direct_Name
5217 and then (Nkind
(Argx
) /= N_Attribute_Reference
5218 or else Present
(Expressions
(Argx
))
5219 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5220 and then (not Is_Entity_Name
(Argx
)
5221 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5223 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5226 -- No further check required if not an entity name
5228 if not Is_Entity_Name
(Argx
) then
5234 Ent
: constant Entity_Id
:= Entity
(Argx
);
5235 Scop
: constant Entity_Id
:= Scope
(Ent
);
5238 -- Case of a pragma applied to a compilation unit: pragma must
5239 -- occur immediately after the program unit in the compilation.
5241 if Is_Compilation_Unit
(Ent
) then
5243 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5246 -- Case of pragma placed immediately after spec
5248 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5251 -- Case of pragma placed immediately after body
5253 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5254 and then Present
(Corresponding_Body
(Decl
))
5258 (Parent
(Unit_Declaration_Node
5259 (Corresponding_Body
(Decl
))));
5261 -- All other cases are illegal
5268 -- Special restricted placement rule from 10.2.1(11.8/2)
5270 elsif Is_Generic_Formal
(Ent
)
5271 and then Prag_Id
= Pragma_Preelaborable_Initialization
5273 OK
:= List_Containing
(N
) =
5274 Generic_Formal_Declarations
5275 (Unit_Declaration_Node
(Scop
));
5277 -- If this is an aspect applied to a subprogram body, the
5278 -- pragma is inserted in its declarative part.
5280 elsif From_Aspect_Specification
(N
)
5281 and then Ent
= Current_Scope
5283 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5287 -- If the aspect is a predicate (possibly others ???) and the
5288 -- context is a record type, this is a discriminant expression
5289 -- within a type declaration, that freezes the predicated
5292 elsif From_Aspect_Specification
(N
)
5293 and then Prag_Id
= Pragma_Predicate
5294 and then Ekind
(Current_Scope
) = E_Record_Type
5295 and then Scop
= Scope
(Current_Scope
)
5299 -- Default case, just check that the pragma occurs in the scope
5300 -- of the entity denoted by the name.
5303 OK
:= Current_Scope
= Scop
;
5308 ("pragma% argument must be in same declarative part", Arg
);
5312 end Check_Arg_Is_Local_Name
;
5314 ---------------------------------
5315 -- Check_Arg_Is_Locking_Policy --
5316 ---------------------------------
5318 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5319 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5322 Check_Arg_Is_Identifier
(Argx
);
5324 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5325 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5327 end Check_Arg_Is_Locking_Policy
;
5329 -----------------------------------------------
5330 -- Check_Arg_Is_Partition_Elaboration_Policy --
5331 -----------------------------------------------
5333 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5334 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5337 Check_Arg_Is_Identifier
(Argx
);
5339 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5341 ("& is not a valid partition elaboration policy name", Argx
);
5343 end Check_Arg_Is_Partition_Elaboration_Policy
;
5345 -------------------------
5346 -- Check_Arg_Is_One_Of --
5347 -------------------------
5349 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5350 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5353 Check_Arg_Is_Identifier
(Argx
);
5355 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5356 Error_Msg_Name_2
:= N1
;
5357 Error_Msg_Name_3
:= N2
;
5358 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5360 end Check_Arg_Is_One_Of
;
5362 procedure Check_Arg_Is_One_Of
5364 N1
, N2
, N3
: Name_Id
)
5366 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5369 Check_Arg_Is_Identifier
(Argx
);
5371 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5372 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5374 end Check_Arg_Is_One_Of
;
5376 procedure Check_Arg_Is_One_Of
5378 N1
, N2
, N3
, N4
: Name_Id
)
5380 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5383 Check_Arg_Is_Identifier
(Argx
);
5385 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5386 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5388 end Check_Arg_Is_One_Of
;
5390 procedure Check_Arg_Is_One_Of
5392 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5394 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5397 Check_Arg_Is_Identifier
(Argx
);
5399 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5400 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5402 end Check_Arg_Is_One_Of
;
5404 ---------------------------------
5405 -- Check_Arg_Is_Queuing_Policy --
5406 ---------------------------------
5408 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5409 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5412 Check_Arg_Is_Identifier
(Argx
);
5414 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5415 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5417 end Check_Arg_Is_Queuing_Policy
;
5419 ---------------------------------------
5420 -- Check_Arg_Is_OK_Static_Expression --
5421 ---------------------------------------
5423 procedure Check_Arg_Is_OK_Static_Expression
5425 Typ
: Entity_Id
:= Empty
)
5428 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5429 end Check_Arg_Is_OK_Static_Expression
;
5431 ------------------------------------------
5432 -- Check_Arg_Is_Task_Dispatching_Policy --
5433 ------------------------------------------
5435 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5436 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5439 Check_Arg_Is_Identifier
(Argx
);
5441 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5443 ("& is not an allowed task dispatching policy name", Argx
);
5445 end Check_Arg_Is_Task_Dispatching_Policy
;
5447 ---------------------
5448 -- Check_Arg_Order --
5449 ---------------------
5451 procedure Check_Arg_Order
(Names
: Name_List
) is
5454 Highest_So_Far
: Natural := 0;
5455 -- Highest index in Names seen do far
5459 for J
in 1 .. Arg_Count
loop
5460 if Chars
(Arg
) /= No_Name
then
5461 for K
in Names
'Range loop
5462 if Chars
(Arg
) = Names
(K
) then
5463 if K
< Highest_So_Far
then
5464 Error_Msg_Name_1
:= Pname
;
5466 ("parameters out of order for pragma%", Arg
);
5467 Error_Msg_Name_1
:= Names
(K
);
5468 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5469 Error_Msg_N
("\% must appear before %", Arg
);
5473 Highest_So_Far
:= K
;
5481 end Check_Arg_Order
;
5483 --------------------------------
5484 -- Check_At_Least_N_Arguments --
5485 --------------------------------
5487 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5489 if Arg_Count
< N
then
5490 Error_Pragma
("too few arguments for pragma%");
5492 end Check_At_Least_N_Arguments
;
5494 -------------------------------
5495 -- Check_At_Most_N_Arguments --
5496 -------------------------------
5498 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5501 if Arg_Count
> N
then
5503 for J
in 1 .. N
loop
5505 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5508 end Check_At_Most_N_Arguments
;
5510 ---------------------
5511 -- Check_Component --
5512 ---------------------
5514 procedure Check_Component
5517 In_Variant_Part
: Boolean := False)
5519 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5520 Sindic
: constant Node_Id
:=
5521 Subtype_Indication
(Component_Definition
(Comp
));
5522 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5525 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5526 -- object constraint, then the component type shall be an Unchecked_
5529 if Nkind
(Sindic
) = N_Subtype_Indication
5530 and then Has_Per_Object_Constraint
(Comp_Id
)
5531 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5534 ("component subtype subject to per-object constraint "
5535 & "must be an Unchecked_Union", Comp
);
5537 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5538 -- the body of a generic unit, or within the body of any of its
5539 -- descendant library units, no part of the type of a component
5540 -- declared in a variant_part of the unchecked union type shall be of
5541 -- a formal private type or formal private extension declared within
5542 -- the formal part of the generic unit.
5544 elsif Ada_Version
>= Ada_2012
5545 and then In_Generic_Body
(UU_Typ
)
5546 and then In_Variant_Part
5547 and then Is_Private_Type
(Typ
)
5548 and then Is_Generic_Type
(Typ
)
5551 ("component of unchecked union cannot be of generic type", Comp
);
5553 elsif Needs_Finalization
(Typ
) then
5555 ("component of unchecked union cannot be controlled", Comp
);
5557 elsif Has_Task
(Typ
) then
5559 ("component of unchecked union cannot have tasks", Comp
);
5561 end Check_Component
;
5563 ----------------------------
5564 -- Check_Duplicate_Pragma --
5565 ----------------------------
5567 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5568 Id
: Entity_Id
:= E
;
5572 -- Nothing to do if this pragma comes from an aspect specification,
5573 -- since we could not be duplicating a pragma, and we dealt with the
5574 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5576 if From_Aspect_Specification
(N
) then
5580 -- Otherwise current pragma may duplicate previous pragma or a
5581 -- previously given aspect specification or attribute definition
5582 -- clause for the same pragma.
5584 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5588 -- If the entity is a type, then we have to make sure that the
5589 -- ostensible duplicate is not for a parent type from which this
5593 if Nkind
(P
) = N_Pragma
then
5595 Args
: constant List_Id
:=
5596 Pragma_Argument_Associations
(P
);
5599 and then Is_Entity_Name
(Expression
(First
(Args
)))
5600 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5601 and then Entity
(Expression
(First
(Args
))) /= E
5607 elsif Nkind
(P
) = N_Aspect_Specification
5608 and then Is_Type
(Entity
(P
))
5609 and then Entity
(P
) /= E
5615 -- Here we have a definite duplicate
5617 Error_Msg_Name_1
:= Pragma_Name
(N
);
5618 Error_Msg_Sloc
:= Sloc
(P
);
5620 -- For a single protected or a single task object, the error is
5621 -- issued on the original entity.
5623 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5624 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5627 if Nkind
(P
) = N_Aspect_Specification
5628 or else From_Aspect_Specification
(P
)
5630 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5632 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5637 end Check_Duplicate_Pragma
;
5639 ----------------------------------
5640 -- Check_Duplicated_Export_Name --
5641 ----------------------------------
5643 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5644 String_Val
: constant String_Id
:= Strval
(Nam
);
5647 -- We are only interested in the export case, and in the case of
5648 -- generics, it is the instance, not the template, that is the
5649 -- problem (the template will generate a warning in any case).
5651 if not Inside_A_Generic
5652 and then (Prag_Id
= Pragma_Export
5654 Prag_Id
= Pragma_Export_Procedure
5656 Prag_Id
= Pragma_Export_Valued_Procedure
5658 Prag_Id
= Pragma_Export_Function
)
5660 for J
in Externals
.First
.. Externals
.Last
loop
5661 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5662 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5663 Error_Msg_N
("external name duplicates name given#", Nam
);
5668 Externals
.Append
(Nam
);
5670 end Check_Duplicated_Export_Name
;
5672 ----------------------------------------
5673 -- Check_Expr_Is_OK_Static_Expression --
5674 ----------------------------------------
5676 procedure Check_Expr_Is_OK_Static_Expression
5678 Typ
: Entity_Id
:= Empty
)
5681 if Present
(Typ
) then
5682 Analyze_And_Resolve
(Expr
, Typ
);
5684 Analyze_And_Resolve
(Expr
);
5687 -- An expression cannot be considered static if its resolution failed
5688 -- or if it's erroneous. Stop the analysis of the related pragma.
5690 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5693 elsif Is_OK_Static_Expression
(Expr
) then
5696 -- An interesting special case, if we have a string literal and we
5697 -- are in Ada 83 mode, then we allow it even though it will not be
5698 -- flagged as static. This allows the use of Ada 95 pragmas like
5699 -- Import in Ada 83 mode. They will of course be flagged with
5700 -- warnings as usual, but will not cause errors.
5702 elsif Ada_Version
= Ada_83
5703 and then Nkind
(Expr
) = N_String_Literal
5707 -- Finally, we have a real error
5710 Error_Msg_Name_1
:= Pname
;
5711 Flag_Non_Static_Expr
5712 (Fix_Error
("argument for pragma% must be a static expression!"),
5716 end Check_Expr_Is_OK_Static_Expression
;
5718 -------------------------
5719 -- Check_First_Subtype --
5720 -------------------------
5722 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5723 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5724 Ent
: constant Entity_Id
:= Entity
(Argx
);
5727 if Is_First_Subtype
(Ent
) then
5730 elsif Is_Type
(Ent
) then
5732 ("pragma% cannot apply to subtype", Argx
);
5734 elsif Is_Object
(Ent
) then
5736 ("pragma% cannot apply to object, requires a type", Argx
);
5740 ("pragma% cannot apply to&, requires a type", Argx
);
5742 end Check_First_Subtype
;
5744 ----------------------
5745 -- Check_Identifier --
5746 ----------------------
5748 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5751 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5753 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5754 Error_Msg_Name_1
:= Pname
;
5755 Error_Msg_Name_2
:= Id
;
5756 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5760 end Check_Identifier
;
5762 --------------------------------
5763 -- Check_Identifier_Is_One_Of --
5764 --------------------------------
5766 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5769 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5771 if Chars
(Arg
) = No_Name
then
5772 Error_Msg_Name_1
:= Pname
;
5773 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5776 elsif Chars
(Arg
) /= N1
5777 and then Chars
(Arg
) /= N2
5779 Error_Msg_Name_1
:= Pname
;
5780 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5784 end Check_Identifier_Is_One_Of
;
5786 ---------------------------
5787 -- Check_In_Main_Program --
5788 ---------------------------
5790 procedure Check_In_Main_Program
is
5791 P
: constant Node_Id
:= Parent
(N
);
5794 -- Must be in subprogram body
5796 if Nkind
(P
) /= N_Subprogram_Body
then
5797 Error_Pragma
("% pragma allowed only in subprogram");
5799 -- Otherwise warn if obviously not main program
5801 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5802 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5804 Error_Msg_Name_1
:= Pname
;
5806 ("??pragma% is only effective in main program", N
);
5808 end Check_In_Main_Program
;
5810 ---------------------------------------
5811 -- Check_Interrupt_Or_Attach_Handler --
5812 ---------------------------------------
5814 procedure Check_Interrupt_Or_Attach_Handler
is
5815 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5816 Handler_Proc
, Proc_Scope
: Entity_Id
;
5821 if Prag_Id
= Pragma_Interrupt_Handler
then
5822 Check_Restriction
(No_Dynamic_Attachment
, N
);
5825 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5826 Proc_Scope
:= Scope
(Handler_Proc
);
5828 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5830 ("argument of pragma% must be protected procedure", Arg1
);
5833 -- For pragma case (as opposed to access case), check placement.
5834 -- We don't need to do that for aspects, because we have the
5835 -- check that they aspect applies an appropriate procedure.
5837 if not From_Aspect_Specification
(N
)
5838 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5840 Error_Pragma
("pragma% must be in protected definition");
5843 if not Is_Library_Level_Entity
(Proc_Scope
) then
5845 ("argument for pragma% must be library level entity", Arg1
);
5848 -- AI05-0033: A pragma cannot appear within a generic body, because
5849 -- instance can be in a nested scope. The check that protected type
5850 -- is itself a library-level declaration is done elsewhere.
5852 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5853 -- handle code prior to AI-0033. Analysis tools typically are not
5854 -- interested in this pragma in any case, so no need to worry too
5855 -- much about its placement.
5857 if Inside_A_Generic
then
5858 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5859 and then In_Package_Body
(Scope
(Current_Scope
))
5860 and then not Relaxed_RM_Semantics
5862 Error_Pragma
("pragma% cannot be used inside a generic");
5865 end Check_Interrupt_Or_Attach_Handler
;
5867 ---------------------------------
5868 -- Check_Loop_Pragma_Placement --
5869 ---------------------------------
5871 procedure Check_Loop_Pragma_Placement
is
5872 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5873 -- Verify whether the current pragma is properly grouped with other
5874 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5875 -- related loop where the pragma appears.
5877 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5878 -- Determine whether an arbitrary statement Stmt denotes pragma
5879 -- Loop_Invariant or Loop_Variant.
5881 procedure Placement_Error
(Constr
: Node_Id
);
5882 pragma No_Return
(Placement_Error
);
5883 -- Node Constr denotes the last loop restricted construct before we
5884 -- encountered an illegal relation between enclosing constructs. Emit
5885 -- an error depending on what Constr was.
5887 --------------------------------
5888 -- Check_Loop_Pragma_Grouping --
5889 --------------------------------
5891 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5892 Stop_Search
: exception;
5893 -- This exception is used to terminate the recursive descent of
5894 -- routine Check_Grouping.
5896 procedure Check_Grouping
(L
: List_Id
);
5897 -- Find the first group of pragmas in list L and if successful,
5898 -- ensure that the current pragma is part of that group. The
5899 -- routine raises Stop_Search once such a check is performed to
5900 -- halt the recursive descent.
5902 procedure Grouping_Error
(Prag
: Node_Id
);
5903 pragma No_Return
(Grouping_Error
);
5904 -- Emit an error concerning the current pragma indicating that it
5905 -- should be placed after pragma Prag.
5907 --------------------
5908 -- Check_Grouping --
5909 --------------------
5911 procedure Check_Grouping
(L
: List_Id
) is
5914 Prag
: Node_Id
:= Empty
; -- init to avoid warning
5917 -- Inspect the list of declarations or statements looking for
5918 -- the first grouping of pragmas:
5921 -- pragma Loop_Invariant ...;
5922 -- pragma Loop_Variant ...;
5924 -- pragma Loop_Variant ...; -- current pragma
5926 -- If the current pragma is not in the grouping, then it must
5927 -- either appear in a different declarative or statement list
5928 -- or the construct at (1) is separating the pragma from the
5932 while Present
(Stmt
) loop
5934 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5935 -- inside a loop or a block housed inside a loop. Inspect
5936 -- the declarations and statements of the block as they may
5937 -- contain the first grouping.
5939 if Nkind
(Stmt
) = N_Block_Statement
then
5940 HSS
:= Handled_Statement_Sequence
(Stmt
);
5942 Check_Grouping
(Declarations
(Stmt
));
5944 if Present
(HSS
) then
5945 Check_Grouping
(Statements
(HSS
));
5948 -- First pragma of the first topmost grouping has been found
5950 elsif Is_Loop_Pragma
(Stmt
) then
5952 -- The group and the current pragma are not in the same
5953 -- declarative or statement list.
5955 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5956 Grouping_Error
(Stmt
);
5958 -- Try to reach the current pragma from the first pragma
5959 -- of the grouping while skipping other members:
5961 -- pragma Loop_Invariant ...; -- first pragma
5962 -- pragma Loop_Variant ...; -- member
5964 -- pragma Loop_Variant ...; -- current pragma
5967 while Present
(Stmt
) loop
5968 -- The current pragma is either the first pragma
5969 -- of the group or is a member of the group.
5970 -- Stop the search as the placement is legal.
5975 -- Skip group members, but keep track of the
5976 -- last pragma in the group.
5978 elsif Is_Loop_Pragma
(Stmt
) then
5981 -- Skip declarations and statements generated by
5982 -- the compiler during expansion. Note that some
5983 -- source statements (e.g. pragma Assert) may have
5984 -- been transformed so that they do not appear as
5985 -- coming from source anymore, so we instead look
5986 -- at their Original_Node.
5988 elsif not Comes_From_Source
(Original_Node
(Stmt
))
5992 -- A non-pragma is separating the group from the
5993 -- current pragma, the placement is illegal.
5996 Grouping_Error
(Prag
);
6002 -- If the traversal did not reach the current pragma,
6003 -- then the list must be malformed.
6005 raise Program_Error
;
6013 --------------------
6014 -- Grouping_Error --
6015 --------------------
6017 procedure Grouping_Error
(Prag
: Node_Id
) is
6019 Error_Msg_Sloc
:= Sloc
(Prag
);
6020 Error_Pragma
("pragma% must appear next to pragma#");
6023 -- Start of processing for Check_Loop_Pragma_Grouping
6026 -- Inspect the statements of the loop or nested blocks housed
6027 -- within to determine whether the current pragma is part of the
6028 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6030 Check_Grouping
(Statements
(Loop_Stmt
));
6033 when Stop_Search
=> null;
6034 end Check_Loop_Pragma_Grouping
;
6036 --------------------
6037 -- Is_Loop_Pragma --
6038 --------------------
6040 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6042 -- Inspect the original node as Loop_Invariant and Loop_Variant
6043 -- pragmas are rewritten to null when assertions are disabled.
6045 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
6047 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
6048 Name_Loop_Invariant
,
6055 ---------------------
6056 -- Placement_Error --
6057 ---------------------
6059 procedure Placement_Error
(Constr
: Node_Id
) is
6060 LA
: constant String := " with Loop_Entry";
6063 if Prag_Id
= Pragma_Assert
then
6064 Error_Msg_String
(1 .. LA
'Length) := LA
;
6065 Error_Msg_Strlen
:= LA
'Length;
6067 Error_Msg_Strlen
:= 0;
6070 if Nkind
(Constr
) = N_Pragma
then
6072 ("pragma %~ must appear immediately within the statements "
6076 ("block containing pragma %~ must appear immediately within "
6077 & "the statements of a loop", Constr
);
6079 end Placement_Error
;
6081 -- Local declarations
6086 -- Start of processing for Check_Loop_Pragma_Placement
6089 -- Check that pragma appears immediately within a loop statement,
6090 -- ignoring intervening block statements.
6094 while Present
(Stmt
) loop
6096 -- The pragma or previous block must appear immediately within the
6097 -- current block's declarative or statement part.
6099 if Nkind
(Stmt
) = N_Block_Statement
then
6100 if (No
(Declarations
(Stmt
))
6101 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6103 List_Containing
(Prev
) /=
6104 Statements
(Handled_Statement_Sequence
(Stmt
))
6106 Placement_Error
(Prev
);
6109 -- Keep inspecting the parents because we are now within a
6110 -- chain of nested blocks.
6114 Stmt
:= Parent
(Stmt
);
6117 -- The pragma or previous block must appear immediately within the
6118 -- statements of the loop.
6120 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6121 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6122 Placement_Error
(Prev
);
6125 -- Stop the traversal because we reached the innermost loop
6126 -- regardless of whether we encountered an error or not.
6130 -- Ignore a handled statement sequence. Note that this node may
6131 -- be related to a subprogram body in which case we will emit an
6132 -- error on the next iteration of the search.
6134 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6135 Stmt
:= Parent
(Stmt
);
6137 -- Any other statement breaks the chain from the pragma to the
6141 Placement_Error
(Prev
);
6146 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6147 -- grouped together with other such pragmas.
6149 if Is_Loop_Pragma
(N
) then
6151 -- The previous check should have located the related loop
6153 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6154 Check_Loop_Pragma_Grouping
(Stmt
);
6156 end Check_Loop_Pragma_Placement
;
6158 -------------------------------------------
6159 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6160 -------------------------------------------
6162 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6171 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6174 elsif Nkind_In
(P
, N_Package_Specification
,
6179 -- Note: the following tests seem a little peculiar, because
6180 -- they test for bodies, but if we were in the statement part
6181 -- of the body, we would already have hit the handled statement
6182 -- sequence, so the only way we get here is by being in the
6183 -- declarative part of the body.
6185 elsif Nkind_In
(P
, N_Subprogram_Body
,
6196 Error_Pragma
("pragma% is not in declarative part or package spec");
6197 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6199 -------------------------
6200 -- Check_No_Identifier --
6201 -------------------------
6203 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6205 if Nkind
(Arg
) = N_Pragma_Argument_Association
6206 and then Chars
(Arg
) /= No_Name
6208 Error_Pragma_Arg_Ident
6209 ("pragma% does not permit identifier& here", Arg
);
6211 end Check_No_Identifier
;
6213 --------------------------
6214 -- Check_No_Identifiers --
6215 --------------------------
6217 procedure Check_No_Identifiers
is
6221 for J
in 1 .. Arg_Count
loop
6222 Check_No_Identifier
(Arg_Node
);
6225 end Check_No_Identifiers
;
6227 ------------------------
6228 -- Check_No_Link_Name --
6229 ------------------------
6231 procedure Check_No_Link_Name
is
6233 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6237 if Present
(Arg4
) then
6239 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6241 end Check_No_Link_Name
;
6243 -------------------------------
6244 -- Check_Optional_Identifier --
6245 -------------------------------
6247 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6250 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6251 and then Chars
(Arg
) /= No_Name
6253 if Chars
(Arg
) /= Id
then
6254 Error_Msg_Name_1
:= Pname
;
6255 Error_Msg_Name_2
:= Id
;
6256 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6260 end Check_Optional_Identifier
;
6262 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6264 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6265 end Check_Optional_Identifier
;
6267 -------------------------------------
6268 -- Check_Static_Boolean_Expression --
6269 -------------------------------------
6271 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6273 if Present
(Expr
) then
6274 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6276 if not Is_OK_Static_Expression
(Expr
) then
6278 ("expression of pragma % must be static", Expr
);
6281 end Check_Static_Boolean_Expression
;
6283 -----------------------------
6284 -- Check_Static_Constraint --
6285 -----------------------------
6287 -- Note: for convenience in writing this procedure, in addition to
6288 -- the officially (i.e. by spec) allowed argument which is always a
6289 -- constraint, it also allows ranges and discriminant associations.
6290 -- Above is not clear ???
6292 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6294 procedure Require_Static
(E
: Node_Id
);
6295 -- Require given expression to be static expression
6297 --------------------
6298 -- Require_Static --
6299 --------------------
6301 procedure Require_Static
(E
: Node_Id
) is
6303 if not Is_OK_Static_Expression
(E
) then
6304 Flag_Non_Static_Expr
6305 ("non-static constraint not allowed in Unchecked_Union!", E
);
6310 -- Start of processing for Check_Static_Constraint
6313 case Nkind
(Constr
) is
6314 when N_Discriminant_Association
=>
6315 Require_Static
(Expression
(Constr
));
6318 Require_Static
(Low_Bound
(Constr
));
6319 Require_Static
(High_Bound
(Constr
));
6321 when N_Attribute_Reference
=>
6322 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6323 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6325 when N_Range_Constraint
=>
6326 Check_Static_Constraint
(Range_Expression
(Constr
));
6328 when N_Index_Or_Discriminant_Constraint
=>
6332 IDC
:= First
(Constraints
(Constr
));
6333 while Present
(IDC
) loop
6334 Check_Static_Constraint
(IDC
);
6342 end Check_Static_Constraint
;
6344 --------------------------------------
6345 -- Check_Valid_Configuration_Pragma --
6346 --------------------------------------
6348 -- A configuration pragma must appear in the context clause of a
6349 -- compilation unit, and only other pragmas may precede it. Note that
6350 -- the test also allows use in a configuration pragma file.
6352 procedure Check_Valid_Configuration_Pragma
is
6354 if not Is_Configuration_Pragma
then
6355 Error_Pragma
("incorrect placement for configuration pragma%");
6357 end Check_Valid_Configuration_Pragma
;
6359 -------------------------------------
6360 -- Check_Valid_Library_Unit_Pragma --
6361 -------------------------------------
6363 procedure Check_Valid_Library_Unit_Pragma
is
6365 Parent_Node
: Node_Id
;
6366 Unit_Name
: Entity_Id
;
6367 Unit_Kind
: Node_Kind
;
6368 Unit_Node
: Node_Id
;
6369 Sindex
: Source_File_Index
;
6372 if not Is_List_Member
(N
) then
6376 Plist
:= List_Containing
(N
);
6377 Parent_Node
:= Parent
(Plist
);
6379 if Parent_Node
= Empty
then
6382 -- Case of pragma appearing after a compilation unit. In this case
6383 -- it must have an argument with the corresponding name and must
6384 -- be part of the following pragmas of its parent.
6386 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6387 if Plist
/= Pragmas_After
(Parent_Node
) then
6390 elsif Arg_Count
= 0 then
6392 ("argument required if outside compilation unit");
6395 Check_No_Identifiers
;
6396 Check_Arg_Count
(1);
6397 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6398 Unit_Kind
:= Nkind
(Unit_Node
);
6400 Analyze
(Get_Pragma_Arg
(Arg1
));
6402 if Unit_Kind
= N_Generic_Subprogram_Declaration
6403 or else Unit_Kind
= N_Subprogram_Declaration
6405 Unit_Name
:= Defining_Entity
(Unit_Node
);
6407 elsif Unit_Kind
in N_Generic_Instantiation
then
6408 Unit_Name
:= Defining_Entity
(Unit_Node
);
6411 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6414 if Chars
(Unit_Name
) /=
6415 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6418 ("pragma% argument is not current unit name", Arg1
);
6421 if Ekind
(Unit_Name
) = E_Package
6422 and then Present
(Renamed_Entity
(Unit_Name
))
6424 Error_Pragma
("pragma% not allowed for renamed package");
6428 -- Pragma appears other than after a compilation unit
6431 -- Here we check for the generic instantiation case and also
6432 -- for the case of processing a generic formal package. We
6433 -- detect these cases by noting that the Sloc on the node
6434 -- does not belong to the current compilation unit.
6436 Sindex
:= Source_Index
(Current_Sem_Unit
);
6438 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6439 Rewrite
(N
, Make_Null_Statement
(Loc
));
6442 -- If before first declaration, the pragma applies to the
6443 -- enclosing unit, and the name if present must be this name.
6445 elsif Is_Before_First_Decl
(N
, Plist
) then
6446 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6447 Unit_Kind
:= Nkind
(Unit_Node
);
6449 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6452 elsif Unit_Kind
= N_Subprogram_Body
6453 and then not Acts_As_Spec
(Unit_Node
)
6457 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6460 elsif Nkind
(Parent_Node
) = N_Package_Specification
6461 and then Plist
= Private_Declarations
(Parent_Node
)
6465 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6466 or else Nkind
(Parent_Node
) =
6467 N_Generic_Subprogram_Declaration
)
6468 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6472 elsif Arg_Count
> 0 then
6473 Analyze
(Get_Pragma_Arg
(Arg1
));
6475 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6477 ("name in pragma% must be enclosing unit", Arg1
);
6480 -- It is legal to have no argument in this context
6486 -- Error if not before first declaration. This is because a
6487 -- library unit pragma argument must be the name of a library
6488 -- unit (RM 10.1.5(7)), but the only names permitted in this
6489 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6490 -- generic subprogram declarations or generic instantiations.
6494 ("pragma% misplaced, must be before first declaration");
6498 end Check_Valid_Library_Unit_Pragma
;
6504 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6505 Clist
: constant Node_Id
:= Component_List
(Variant
);
6509 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6510 while Present
(Comp
) loop
6511 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6512 Next_Non_Pragma
(Comp
);
6516 ---------------------------
6517 -- Ensure_Aggregate_Form --
6518 ---------------------------
6520 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6521 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6522 Expr
: constant Node_Id
:= Expression
(Arg
);
6523 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6524 Comps
: List_Id
:= No_List
;
6525 Exprs
: List_Id
:= No_List
;
6526 Nam
: Name_Id
:= No_Name
;
6527 Nam_Loc
: Source_Ptr
;
6530 -- The pragma argument is in positional form:
6532 -- pragma Depends (Nam => ...)
6536 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6537 -- argument association.
6539 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6541 Nam_Loc
:= Sloc
(Arg
);
6543 -- Remove the pragma argument name as this will be captured in the
6546 Set_Chars
(Arg
, No_Name
);
6549 -- The argument is already in aggregate form, but the presence of a
6550 -- name causes this to be interpreted as named association which in
6551 -- turn must be converted into an aggregate.
6553 -- pragma Global (In_Out => (A, B, C))
6557 -- pragma Global ((In_Out => (A, B, C)))
6559 -- aggregate aggregate
6561 if Nkind
(Expr
) = N_Aggregate
then
6562 if Nam
= No_Name
then
6566 -- Do not transform a null argument into an aggregate as N_Null has
6567 -- special meaning in formal verification pragmas.
6569 elsif Nkind
(Expr
) = N_Null
then
6573 -- Everything comes from source if the original comes from source
6575 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6577 -- Positional argument is transformed into an aggregate with an
6578 -- Expressions list.
6580 if Nam
= No_Name
then
6581 Exprs
:= New_List
(Relocate_Node
(Expr
));
6583 -- An associative argument is transformed into an aggregate with
6584 -- Component_Associations.
6588 Make_Component_Association
(Loc
,
6589 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6590 Expression
=> Relocate_Node
(Expr
)));
6593 Set_Expression
(Arg
,
6594 Make_Aggregate
(Loc
,
6595 Component_Associations
=> Comps
,
6596 Expressions
=> Exprs
));
6598 -- Restore Comes_From_Source default
6600 Set_Comes_From_Source_Default
(CFSD
);
6601 end Ensure_Aggregate_Form
;
6607 procedure Error_Pragma
(Msg
: String) is
6609 Error_Msg_Name_1
:= Pname
;
6610 Error_Msg_N
(Fix_Error
(Msg
), N
);
6614 ----------------------
6615 -- Error_Pragma_Arg --
6616 ----------------------
6618 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6620 Error_Msg_Name_1
:= Pname
;
6621 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6623 end Error_Pragma_Arg
;
6625 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6627 Error_Msg_Name_1
:= Pname
;
6628 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6629 Error_Pragma_Arg
(Msg2
, Arg
);
6630 end Error_Pragma_Arg
;
6632 ----------------------------
6633 -- Error_Pragma_Arg_Ident --
6634 ----------------------------
6636 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6638 Error_Msg_Name_1
:= Pname
;
6639 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6641 end Error_Pragma_Arg_Ident
;
6643 ----------------------
6644 -- Error_Pragma_Ref --
6645 ----------------------
6647 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6649 Error_Msg_Name_1
:= Pname
;
6650 Error_Msg_Sloc
:= Sloc
(Ref
);
6651 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6653 end Error_Pragma_Ref
;
6655 ------------------------
6656 -- Find_Lib_Unit_Name --
6657 ------------------------
6659 function Find_Lib_Unit_Name
return Entity_Id
is
6661 -- Return inner compilation unit entity, for case of nested
6662 -- categorization pragmas. This happens in generic unit.
6664 if Nkind
(Parent
(N
)) = N_Package_Specification
6665 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6667 return Defining_Entity
(Parent
(N
));
6669 return Current_Scope
;
6671 end Find_Lib_Unit_Name
;
6673 ----------------------------
6674 -- Find_Program_Unit_Name --
6675 ----------------------------
6677 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6678 Unit_Name
: Entity_Id
;
6679 Unit_Kind
: Node_Kind
;
6680 P
: constant Node_Id
:= Parent
(N
);
6683 if Nkind
(P
) = N_Compilation_Unit
then
6684 Unit_Kind
:= Nkind
(Unit
(P
));
6686 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6687 N_Package_Declaration
)
6688 or else Unit_Kind
in N_Generic_Declaration
6690 Unit_Name
:= Defining_Entity
(Unit
(P
));
6692 if Chars
(Id
) = Chars
(Unit_Name
) then
6693 Set_Entity
(Id
, Unit_Name
);
6694 Set_Etype
(Id
, Etype
(Unit_Name
));
6696 Set_Etype
(Id
, Any_Type
);
6698 ("cannot find program unit referenced by pragma%");
6702 Set_Etype
(Id
, Any_Type
);
6703 Error_Pragma
("pragma% inapplicable to this unit");
6709 end Find_Program_Unit_Name
;
6711 -----------------------------------------
6712 -- Find_Unique_Parameterless_Procedure --
6713 -----------------------------------------
6715 function Find_Unique_Parameterless_Procedure
6717 Arg
: Node_Id
) return Entity_Id
6719 Proc
: Entity_Id
:= Empty
;
6722 -- The body of this procedure needs some comments ???
6724 if not Is_Entity_Name
(Name
) then
6726 ("argument of pragma% must be entity name", Arg
);
6728 elsif not Is_Overloaded
(Name
) then
6729 Proc
:= Entity
(Name
);
6731 if Ekind
(Proc
) /= E_Procedure
6732 or else Present
(First_Formal
(Proc
))
6735 ("argument of pragma% must be parameterless procedure", Arg
);
6740 Found
: Boolean := False;
6742 Index
: Interp_Index
;
6745 Get_First_Interp
(Name
, Index
, It
);
6746 while Present
(It
.Nam
) loop
6749 if Ekind
(Proc
) = E_Procedure
6750 and then No
(First_Formal
(Proc
))
6754 Set_Entity
(Name
, Proc
);
6755 Set_Is_Overloaded
(Name
, False);
6758 ("ambiguous handler name for pragma% ", Arg
);
6762 Get_Next_Interp
(Index
, It
);
6767 ("argument of pragma% must be parameterless procedure",
6770 Proc
:= Entity
(Name
);
6776 end Find_Unique_Parameterless_Procedure
;
6782 function Fix_Error
(Msg
: String) return String is
6783 Res
: String (Msg
'Range) := Msg
;
6784 Res_Last
: Natural := Msg
'Last;
6788 -- If we have a rewriting of another pragma, go to that pragma
6790 if Is_Rewrite_Substitution
(N
)
6791 and then Nkind
(Original_Node
(N
)) = N_Pragma
6793 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6796 -- Case where pragma comes from an aspect specification
6798 if From_Aspect_Specification
(N
) then
6800 -- Change appearence of "pragma" in message to "aspect"
6803 while J
<= Res_Last
- 5 loop
6804 if Res
(J
.. J
+ 5) = "pragma" then
6805 Res
(J
.. J
+ 5) := "aspect";
6813 -- Change "argument of" at start of message to "entity for"
6816 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6818 Res
(Res
'First .. Res
'First + 9) := "entity for";
6819 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6820 Res
(Res
'First + 11 .. Res_Last
);
6821 Res_Last
:= Res_Last
- 1;
6824 -- Change "argument" at start of message to "entity"
6827 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6829 Res
(Res
'First .. Res
'First + 5) := "entity";
6830 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6831 Res
(Res
'First + 8 .. Res_Last
);
6832 Res_Last
:= Res_Last
- 2;
6835 -- Get name from corresponding aspect
6837 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6840 -- Return possibly modified message
6842 return Res
(Res
'First .. Res_Last
);
6845 -------------------------
6846 -- Gather_Associations --
6847 -------------------------
6849 procedure Gather_Associations
6851 Args
: out Args_List
)
6856 -- Initialize all parameters to Empty
6858 for J
in Args
'Range loop
6862 -- That's all we have to do if there are no argument associations
6864 if No
(Pragma_Argument_Associations
(N
)) then
6868 -- Otherwise first deal with any positional parameters present
6870 Arg
:= First
(Pragma_Argument_Associations
(N
));
6871 for Index
in Args
'Range loop
6872 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6873 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6877 -- Positional parameters all processed, if any left, then we
6878 -- have too many positional parameters.
6880 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6882 ("too many positional associations for pragma%", Arg
);
6885 -- Process named parameters if any are present
6887 while Present
(Arg
) loop
6888 if Chars
(Arg
) = No_Name
then
6890 ("positional association cannot follow named association",
6894 for Index
in Names
'Range loop
6895 if Names
(Index
) = Chars
(Arg
) then
6896 if Present
(Args
(Index
)) then
6898 ("duplicate argument association for pragma%", Arg
);
6900 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6905 if Index
= Names
'Last then
6906 Error_Msg_Name_1
:= Pname
;
6907 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6909 -- Check for possible misspelling
6911 for Index1
in Names
'Range loop
6912 if Is_Bad_Spelling_Of
6913 (Chars
(Arg
), Names
(Index1
))
6915 Error_Msg_Name_1
:= Names
(Index1
);
6916 Error_Msg_N
-- CODEFIX
6917 ("\possible misspelling of%", Arg
);
6929 end Gather_Associations
;
6935 procedure GNAT_Pragma
is
6937 -- We need to check the No_Implementation_Pragmas restriction for
6938 -- the case of a pragma from source. Note that the case of aspects
6939 -- generating corresponding pragmas marks these pragmas as not being
6940 -- from source, so this test also catches that case.
6942 if Comes_From_Source
(N
) then
6943 Check_Restriction
(No_Implementation_Pragmas
, N
);
6947 --------------------------
6948 -- Is_Before_First_Decl --
6949 --------------------------
6951 function Is_Before_First_Decl
6952 (Pragma_Node
: Node_Id
;
6953 Decls
: List_Id
) return Boolean
6955 Item
: Node_Id
:= First
(Decls
);
6958 -- Only other pragmas can come before this pragma
6961 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6964 elsif Item
= Pragma_Node
then
6970 end Is_Before_First_Decl
;
6972 -----------------------------
6973 -- Is_Configuration_Pragma --
6974 -----------------------------
6976 -- A configuration pragma must appear in the context clause of a
6977 -- compilation unit, and only other pragmas may precede it. Note that
6978 -- the test below also permits use in a configuration pragma file.
6980 function Is_Configuration_Pragma
return Boolean is
6981 Lis
: constant List_Id
:= List_Containing
(N
);
6982 Par
: constant Node_Id
:= Parent
(N
);
6986 -- If no parent, then we are in the configuration pragma file,
6987 -- so the placement is definitely appropriate.
6992 -- Otherwise we must be in the context clause of a compilation unit
6993 -- and the only thing allowed before us in the context list is more
6994 -- configuration pragmas.
6996 elsif Nkind
(Par
) = N_Compilation_Unit
6997 and then Context_Items
(Par
) = Lis
7004 elsif Nkind
(Prg
) /= N_Pragma
then
7014 end Is_Configuration_Pragma
;
7016 --------------------------
7017 -- Is_In_Context_Clause --
7018 --------------------------
7020 function Is_In_Context_Clause
return Boolean is
7022 Parent_Node
: Node_Id
;
7025 if not Is_List_Member
(N
) then
7029 Plist
:= List_Containing
(N
);
7030 Parent_Node
:= Parent
(Plist
);
7032 if Parent_Node
= Empty
7033 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7034 or else Context_Items
(Parent_Node
) /= Plist
7041 end Is_In_Context_Clause
;
7043 ---------------------------------
7044 -- Is_Static_String_Expression --
7045 ---------------------------------
7047 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7048 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7049 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7052 Analyze_And_Resolve
(Argx
);
7054 -- Special case Ada 83, where the expression will never be static,
7055 -- but we will return true if we had a string literal to start with.
7057 if Ada_Version
= Ada_83
then
7060 -- Normal case, true only if we end up with a string literal that
7061 -- is marked as being the result of evaluating a static expression.
7064 return Is_OK_Static_Expression
(Argx
)
7065 and then Nkind
(Argx
) = N_String_Literal
;
7068 end Is_Static_String_Expression
;
7070 ----------------------
7071 -- Pragma_Misplaced --
7072 ----------------------
7074 procedure Pragma_Misplaced
is
7076 Error_Pragma
("incorrect placement of pragma%");
7077 end Pragma_Misplaced
;
7079 ------------------------------------------------
7080 -- Process_Atomic_Independent_Shared_Volatile --
7081 ------------------------------------------------
7083 procedure Process_Atomic_Independent_Shared_Volatile
is
7084 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
7085 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7087 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7088 -- Appropriately set flags on the given entity (either an array or
7089 -- record component, or an object declaration) according to the
7092 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7093 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7094 -- no explicit alignment was given, set alignment to unknown, since
7095 -- back end knows what the alignment requirements are for atomic and
7096 -- full access arrays. Note: this is necessary for derived types.
7098 -------------------------
7099 -- Check_VFA_Conflicts --
7100 -------------------------
7102 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7106 VFA_And_Atomic
: Boolean := False;
7107 -- Set True if atomic component present
7109 VFA_And_Aliased
: Boolean := False;
7110 -- Set True if aliased component present
7113 -- Fetch the type in case we are dealing with an object or
7116 if Is_Type
(Ent
) then
7119 pragma Assert
(Is_Object
(Ent
)
7121 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7126 -- Check Atomic and VFA used together
7128 if Prag_Id
= Pragma_Volatile_Full_Access
7129 or else Is_Volatile_Full_Access
(Ent
)
7131 if Prag_Id
= Pragma_Atomic
7132 or else Prag_Id
= Pragma_Shared
7133 or else Is_Atomic
(Ent
)
7135 VFA_And_Atomic
:= True;
7137 elsif Is_Array_Type
(Typ
) then
7138 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7140 -- Note: Has_Atomic_Components is not used below, as this flag
7141 -- represents the pragma of the same name, Atomic_Components,
7142 -- which only applies to arrays.
7144 elsif Is_Record_Type
(Typ
) then
7145 -- Attributes cannot be applied to discriminants, only
7146 -- regular record components.
7148 Comp
:= First_Component
(Typ
);
7149 while Present
(Comp
) loop
7151 or else Is_Atomic
(Typ
)
7153 VFA_And_Atomic
:= True;
7158 Next_Component
(Comp
);
7162 if VFA_And_Atomic
then
7164 ("cannot have Volatile_Full_Access and Atomic for same "
7169 -- Check for the application of VFA to an entity that has aliased
7172 if Prag_Id
= Pragma_Volatile_Full_Access
then
7173 if Is_Array_Type
(Typ
)
7174 and then Has_Aliased_Components
(Typ
)
7176 VFA_And_Aliased
:= True;
7178 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7179 -- and Has_Independent_Components, applies only to arrays.
7180 -- However, this flag does not have a corresponding pragma, so
7181 -- perhaps it should be possible to apply it to record types as
7182 -- well. Should this be done ???
7184 elsif Is_Record_Type
(Typ
) then
7185 -- It is possible to have an aliased discriminant, so they
7186 -- must be checked along with normal components.
7188 Comp
:= First_Component_Or_Discriminant
(Typ
);
7189 while Present
(Comp
) loop
7190 if Is_Aliased
(Comp
)
7191 or else Is_Aliased
(Etype
(Comp
))
7193 VFA_And_Aliased
:= True;
7194 Check_SPARK_05_Restriction
7195 ("aliased is not allowed", Comp
);
7200 Next_Component_Or_Discriminant
(Comp
);
7204 if VFA_And_Aliased
then
7206 ("cannot apply Volatile_Full_Access (aliased component "
7210 end Check_VFA_Conflicts
;
7212 ------------------------------
7213 -- Mark_Component_Or_Object --
7214 ------------------------------
7216 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7218 if Prag_Id
= Pragma_Atomic
7219 or else Prag_Id
= Pragma_Shared
7220 or else Prag_Id
= Pragma_Volatile_Full_Access
7222 if Prag_Id
= Pragma_Volatile_Full_Access
then
7223 Set_Is_Volatile_Full_Access
(Ent
);
7225 Set_Is_Atomic
(Ent
);
7228 -- If the object declaration has an explicit initialization, a
7229 -- temporary may have to be created to hold the expression, to
7230 -- ensure that access to the object remains atomic.
7232 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7233 and then Present
(Expression
(Parent
(Ent
)))
7235 Set_Has_Delayed_Freeze
(Ent
);
7239 -- Atomic/Shared/Volatile_Full_Access imply Independent
7241 if Prag_Id
/= Pragma_Volatile
then
7242 Set_Is_Independent
(Ent
);
7244 if Prag_Id
= Pragma_Independent
then
7245 Record_Independence_Check
(N
, Ent
);
7249 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7251 if Prag_Id
/= Pragma_Independent
then
7252 Set_Is_Volatile
(Ent
);
7253 Set_Treat_As_Volatile
(Ent
);
7255 end Mark_Component_Or_Object
;
7257 --------------------
7258 -- Set_Atomic_VFA --
7259 --------------------
7261 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7263 if Prag_Id
= Pragma_Volatile_Full_Access
then
7264 Set_Is_Volatile_Full_Access
(Ent
);
7266 Set_Is_Atomic
(Ent
);
7269 if not Has_Alignment_Clause
(Ent
) then
7270 Set_Alignment
(Ent
, Uint_0
);
7280 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7283 Check_Ada_83_Warning
;
7284 Check_No_Identifiers
;
7285 Check_Arg_Count
(1);
7286 Check_Arg_Is_Local_Name
(Arg1
);
7287 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7289 if Etype
(E_Arg
) = Any_Type
then
7293 E
:= Entity
(E_Arg
);
7295 -- A pragma that applies to a Ghost entity becomes Ghost for the
7296 -- purposes of legality checks and removal of ignored Ghost code.
7298 Mark_Ghost_Pragma
(N
, E
);
7300 -- Check duplicate before we chain ourselves
7302 Check_Duplicate_Pragma
(E
);
7304 -- Check appropriateness of the entity
7306 Decl
:= Declaration_Node
(E
);
7308 -- Deal with the case where the pragma/attribute is applied to a type
7311 if Rep_Item_Too_Early
(E
, N
)
7312 or else Rep_Item_Too_Late
(E
, N
)
7316 Check_First_Subtype
(Arg1
);
7319 -- Attribute belongs on the base type. If the view of the type is
7320 -- currently private, it also belongs on the underlying type.
7322 if Prag_Id
= Pragma_Atomic
7323 or else Prag_Id
= Pragma_Shared
7324 or else Prag_Id
= Pragma_Volatile_Full_Access
7327 Set_Atomic_VFA
(Base_Type
(E
));
7328 Set_Atomic_VFA
(Underlying_Type
(E
));
7331 -- Atomic/Shared/Volatile_Full_Access imply Independent
7333 if Prag_Id
/= Pragma_Volatile
then
7334 Set_Is_Independent
(E
);
7335 Set_Is_Independent
(Base_Type
(E
));
7336 Set_Is_Independent
(Underlying_Type
(E
));
7338 if Prag_Id
= Pragma_Independent
then
7339 Record_Independence_Check
(N
, Base_Type
(E
));
7343 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7345 if Prag_Id
/= Pragma_Independent
then
7346 Set_Is_Volatile
(E
);
7347 Set_Is_Volatile
(Base_Type
(E
));
7348 Set_Is_Volatile
(Underlying_Type
(E
));
7350 Set_Treat_As_Volatile
(E
);
7351 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7354 -- Apply Volatile to the composite type's individual components,
7357 if Prag_Id
= Pragma_Volatile
7358 and then Is_Record_Type
(Etype
(E
))
7363 Comp
:= First_Component
(E
);
7364 while Present
(Comp
) loop
7365 Mark_Component_Or_Object
(Comp
);
7367 Next_Component
(Comp
);
7372 -- Deal with the case where the pragma/attribute applies to a
7373 -- component or object declaration.
7375 elsif Nkind
(Decl
) = N_Object_Declaration
7376 or else (Nkind
(Decl
) = N_Component_Declaration
7377 and then Original_Record_Component
(E
) = E
)
7379 if Rep_Item_Too_Late
(E
, N
) then
7383 Mark_Component_Or_Object
(E
);
7385 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7388 -- Perform the checks needed to assure the proper use of the GNAT
7389 -- pragma Volatile_Full_Access.
7391 Check_VFA_Conflicts
(E
);
7393 -- The following check is only relevant when SPARK_Mode is on as
7394 -- this is not a standard Ada legality rule. Pragma Volatile can
7395 -- only apply to a full type declaration or an object declaration
7396 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7397 -- untagged derived types that are rewritten as subtypes of their
7398 -- respective root types.
7401 and then Prag_Id
= Pragma_Volatile
7403 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7404 N_Object_Declaration
)
7407 ("argument of pragma % must denote a full type or object "
7408 & "declaration", Arg1
);
7410 end Process_Atomic_Independent_Shared_Volatile
;
7412 -------------------------------------------
7413 -- Process_Compile_Time_Warning_Or_Error --
7414 -------------------------------------------
7416 procedure Process_Compile_Time_Warning_Or_Error
is
7417 Validation_Needed
: Boolean := False;
7419 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7420 -- Tree visitor that checks if N is an attribute reference that can
7421 -- be statically computed by the back end. Validation_Needed is set
7422 -- to True if found.
7428 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7430 if Nkind
(N
) = N_Attribute_Reference
7431 and then Is_Entity_Name
(Prefix
(N
))
7434 Attr_Id
: constant Attribute_Id
:=
7435 Get_Attribute_Id
(Attribute_Name
(N
));
7437 if Attr_Id
= Attribute_Alignment
7438 or else Attr_Id
= Attribute_Size
7440 Validation_Needed
:= True;
7448 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7452 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7454 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7457 Check_Arg_Count
(2);
7458 Check_No_Identifiers
;
7459 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7460 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7462 if Compile_Time_Known_Value
(Arg1x
) then
7463 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7465 -- Register the expression for its validation after the back end has
7466 -- been called if it has occurrences of attributes Size or Alignment
7467 -- (because they may be statically computed by the back end and hence
7468 -- the whole expression needs to be reevaluated).
7471 Check_Expression
(Arg1x
);
7473 if Validation_Needed
then
7474 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7477 end Process_Compile_Time_Warning_Or_Error
;
7479 ------------------------
7480 -- Process_Convention --
7481 ------------------------
7483 procedure Process_Convention
7484 (C
: out Convention_Id
;
7485 Ent
: out Entity_Id
)
7489 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7490 -- Called if we have more than one Export/Import/Convention pragma.
7491 -- This is generally illegal, but we have a special case of allowing
7492 -- Import and Interface to coexist if they specify the convention in
7493 -- a consistent manner. We are allowed to do this, since Interface is
7494 -- an implementation defined pragma, and we choose to do it since we
7495 -- know Rational allows this combination. S is the entity id of the
7496 -- subprogram in question. This procedure also sets the special flag
7497 -- Import_Interface_Present in both pragmas in the case where we do
7498 -- have matching Import and Interface pragmas.
7500 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7501 -- Set convention in entity E, and also flag that the entity has a
7502 -- convention pragma. If entity is for a private or incomplete type,
7503 -- also set convention and flag on underlying type. This procedure
7504 -- also deals with the special case of C_Pass_By_Copy convention,
7505 -- and error checks for inappropriate convention specification.
7507 -------------------------------
7508 -- Diagnose_Multiple_Pragmas --
7509 -------------------------------
7511 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7512 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7516 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7517 -- Decl is a pragma node. This function returns True if this
7518 -- pragma has a first argument that is an identifier with a
7519 -- Chars field corresponding to the Convention_Id C.
7521 function Same_Name
(Decl
: Node_Id
) return Boolean;
7522 -- Decl is a pragma node. This function returns True if this
7523 -- pragma has a second argument that is an identifier with a
7524 -- Chars field that matches the Chars of the current subprogram.
7526 ---------------------
7527 -- Same_Convention --
7528 ---------------------
7530 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7531 Arg1
: constant Node_Id
:=
7532 First
(Pragma_Argument_Associations
(Decl
));
7535 if Present
(Arg1
) then
7537 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7539 if Nkind
(Arg
) = N_Identifier
7540 and then Is_Convention_Name
(Chars
(Arg
))
7541 and then Get_Convention_Id
(Chars
(Arg
)) = C
7549 end Same_Convention
;
7555 function Same_Name
(Decl
: Node_Id
) return Boolean is
7556 Arg1
: constant Node_Id
:=
7557 First
(Pragma_Argument_Associations
(Decl
));
7565 Arg2
:= Next
(Arg1
);
7572 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7574 if Nkind
(Arg
) = N_Identifier
7575 and then Chars
(Arg
) = Chars
(S
)
7584 -- Start of processing for Diagnose_Multiple_Pragmas
7589 -- Definitely give message if we have Convention/Export here
7591 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7594 -- If we have an Import or Export, scan back from pragma to
7595 -- find any previous pragma applying to the same procedure.
7596 -- The scan will be terminated by the start of the list, or
7597 -- hitting the subprogram declaration. This won't allow one
7598 -- pragma to appear in the public part and one in the private
7599 -- part, but that seems very unlikely in practice.
7603 while Present
(Decl
) and then Decl
/= Pdec
loop
7605 -- Look for pragma with same name as us
7607 if Nkind
(Decl
) = N_Pragma
7608 and then Same_Name
(Decl
)
7610 -- Give error if same as our pragma or Export/Convention
7612 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7615 Pragma_Name_Unmapped
(N
))
7619 -- Case of Import/Interface or the other way round
7621 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7622 Name_Interface
, Name_Import
)
7624 -- Here we know that we have Import and Interface. It
7625 -- doesn't matter which way round they are. See if
7626 -- they specify the same convention. If so, all OK,
7627 -- and set special flags to stop other messages
7629 if Same_Convention
(Decl
) then
7630 Set_Import_Interface_Present
(N
);
7631 Set_Import_Interface_Present
(Decl
);
7634 -- If different conventions, special message
7637 Error_Msg_Sloc
:= Sloc
(Decl
);
7639 ("convention differs from that given#", Arg1
);
7649 -- Give message if needed if we fall through those tests
7650 -- except on Relaxed_RM_Semantics where we let go: either this
7651 -- is a case accepted/ignored by other Ada compilers (e.g.
7652 -- a mix of Convention and Import), or another error will be
7653 -- generated later (e.g. using both Import and Export).
7655 if Err
and not Relaxed_RM_Semantics
then
7657 ("at most one Convention/Export/Import pragma is allowed",
7660 end Diagnose_Multiple_Pragmas
;
7662 --------------------------------
7663 -- Set_Convention_From_Pragma --
7664 --------------------------------
7666 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7668 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7669 -- for an overridden dispatching operation. Technically this is
7670 -- an amendment and should only be done in Ada 2005 mode. However,
7671 -- this is clearly a mistake, since the problem that is addressed
7672 -- by this AI is that there is a clear gap in the RM.
7674 if Is_Dispatching_Operation
(E
)
7675 and then Present
(Overridden_Operation
(E
))
7676 and then C
/= Convention
(Overridden_Operation
(E
))
7679 ("cannot change convention for overridden dispatching "
7680 & "operation", Arg1
);
7683 -- Special checks for Convention_Stdcall
7685 if C
= Convention_Stdcall
then
7687 -- A dispatching call is not allowed. A dispatching subprogram
7688 -- cannot be used to interface to the Win32 API, so in fact
7689 -- this check does not impose any effective restriction.
7691 if Is_Dispatching_Operation
(E
) then
7692 Error_Msg_Sloc
:= Sloc
(E
);
7694 -- Note: make this unconditional so that if there is more
7695 -- than one call to which the pragma applies, we get a
7696 -- message for each call. Also don't use Error_Pragma,
7697 -- so that we get multiple messages.
7700 ("dispatching subprogram# cannot use Stdcall convention!",
7703 -- Several allowed cases
7705 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7709 or else Ekind
(E
) = E_Variable
7711 -- A component as well. The entity does not have its Ekind
7712 -- set until the enclosing record declaration is fully
7715 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7717 -- An access to subprogram is also allowed
7721 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7723 -- Allow internal call to set convention of subprogram type
7725 or else Ekind
(E
) = E_Subprogram_Type
7731 ("second argument of pragma% must be subprogram (type)",
7736 -- Set the convention
7738 Set_Convention
(E
, C
);
7739 Set_Has_Convention_Pragma
(E
);
7741 -- For the case of a record base type, also set the convention of
7742 -- any anonymous access types declared in the record which do not
7743 -- currently have a specified convention.
7745 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7750 Comp
:= First_Component
(E
);
7751 while Present
(Comp
) loop
7752 if Present
(Etype
(Comp
))
7753 and then Ekind_In
(Etype
(Comp
),
7754 E_Anonymous_Access_Type
,
7755 E_Anonymous_Access_Subprogram_Type
)
7756 and then not Has_Convention_Pragma
(Comp
)
7758 Set_Convention
(Comp
, C
);
7761 Next_Component
(Comp
);
7766 -- Deal with incomplete/private type case, where underlying type
7767 -- is available, so set convention of that underlying type.
7769 if Is_Incomplete_Or_Private_Type
(E
)
7770 and then Present
(Underlying_Type
(E
))
7772 Set_Convention
(Underlying_Type
(E
), C
);
7773 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7776 -- A class-wide type should inherit the convention of the specific
7777 -- root type (although this isn't specified clearly by the RM).
7779 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7780 Set_Convention
(Class_Wide_Type
(E
), C
);
7783 -- If the entity is a record type, then check for special case of
7784 -- C_Pass_By_Copy, which is treated the same as C except that the
7785 -- special record flag is set. This convention is only permitted
7786 -- on record types (see AI95-00131).
7788 if Cname
= Name_C_Pass_By_Copy
then
7789 if Is_Record_Type
(E
) then
7790 Set_C_Pass_By_Copy
(Base_Type
(E
));
7791 elsif Is_Incomplete_Or_Private_Type
(E
)
7792 and then Is_Record_Type
(Underlying_Type
(E
))
7794 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7797 ("C_Pass_By_Copy convention allowed only for record type",
7802 -- If the entity is a derived boolean type, check for the special
7803 -- case of convention C, C++, or Fortran, where we consider any
7804 -- nonzero value to represent true.
7806 if Is_Discrete_Type
(E
)
7807 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7813 C
= Convention_Fortran
)
7815 Set_Nonzero_Is_True
(Base_Type
(E
));
7817 end Set_Convention_From_Pragma
;
7821 Comp_Unit
: Unit_Number_Type
;
7826 -- Start of processing for Process_Convention
7829 Check_At_Least_N_Arguments
(2);
7830 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7831 Check_Arg_Is_Identifier
(Arg1
);
7832 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7834 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7835 -- tested again below to set the critical flag).
7837 if Cname
= Name_C_Pass_By_Copy
then
7840 -- Otherwise we must have something in the standard convention list
7842 elsif Is_Convention_Name
(Cname
) then
7843 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7845 -- Otherwise warn on unrecognized convention
7848 if Warn_On_Export_Import
then
7850 ("??unrecognized convention name, C assumed",
7851 Get_Pragma_Arg
(Arg1
));
7857 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7858 Check_Arg_Is_Local_Name
(Arg2
);
7860 Id
:= Get_Pragma_Arg
(Arg2
);
7863 if not Is_Entity_Name
(Id
) then
7864 Error_Pragma_Arg
("entity name required", Arg2
);
7869 -- Set entity to return
7873 -- Ada_Pass_By_Copy special checking
7875 if C
= Convention_Ada_Pass_By_Copy
then
7876 if not Is_First_Subtype
(E
) then
7878 ("convention `Ada_Pass_By_Copy` only allowed for types",
7882 if Is_By_Reference_Type
(E
) then
7884 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7888 -- Ada_Pass_By_Reference special checking
7890 elsif C
= Convention_Ada_Pass_By_Reference
then
7891 if not Is_First_Subtype
(E
) then
7893 ("convention `Ada_Pass_By_Reference` only allowed for types",
7897 if Is_By_Copy_Type
(E
) then
7899 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7904 -- Go to renamed subprogram if present, since convention applies to
7905 -- the actual renamed entity, not to the renaming entity. If the
7906 -- subprogram is inherited, go to parent subprogram.
7908 if Is_Subprogram
(E
)
7909 and then Present
(Alias
(E
))
7911 if Nkind
(Parent
(Declaration_Node
(E
))) =
7912 N_Subprogram_Renaming_Declaration
7914 if Scope
(E
) /= Scope
(Alias
(E
)) then
7916 ("cannot apply pragma% to non-local entity&#", E
);
7921 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7922 N_Private_Extension_Declaration
)
7923 and then Scope
(E
) = Scope
(Alias
(E
))
7927 -- Return the parent subprogram the entity was inherited from
7933 -- Check that we are not applying this to a specless body. Relax this
7934 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7936 if Is_Subprogram
(E
)
7937 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7938 and then not Relaxed_RM_Semantics
7941 ("pragma% requires separate spec and must come before body");
7944 -- Check that we are not applying this to a named constant
7946 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7947 Error_Msg_Name_1
:= Pname
;
7949 ("cannot apply pragma% to named constant!",
7950 Get_Pragma_Arg
(Arg2
));
7952 ("\supply appropriate type for&!", Arg2
);
7955 if Ekind
(E
) = E_Enumeration_Literal
then
7956 Error_Pragma
("enumeration literal not allowed for pragma%");
7959 -- Check for rep item appearing too early or too late
7961 if Etype
(E
) = Any_Type
7962 or else Rep_Item_Too_Early
(E
, N
)
7966 elsif Present
(Underlying_Type
(E
)) then
7967 E
:= Underlying_Type
(E
);
7970 if Rep_Item_Too_Late
(E
, N
) then
7974 if Has_Convention_Pragma
(E
) then
7975 Diagnose_Multiple_Pragmas
(E
);
7977 elsif Convention
(E
) = Convention_Protected
7978 or else Ekind
(Scope
(E
)) = E_Protected_Type
7981 ("a protected operation cannot be given a different convention",
7985 -- For Intrinsic, a subprogram is required
7987 if C
= Convention_Intrinsic
7988 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7990 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7992 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7994 ("second argument of pragma% must be a subprogram", Arg2
);
7998 -- Deal with non-subprogram cases
8000 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8001 Set_Convention_From_Pragma
(E
);
8005 -- The pragma must apply to a first subtype, but it can also
8006 -- apply to a generic type in a generic formal part, in which
8007 -- case it will also appear in the corresponding instance.
8009 if Is_Generic_Type
(E
) or else In_Instance
then
8012 Check_First_Subtype
(Arg2
);
8015 Set_Convention_From_Pragma
(Base_Type
(E
));
8017 -- For access subprograms, we must set the convention on the
8018 -- internally generated directly designated type as well.
8020 if Ekind
(E
) = E_Access_Subprogram_Type
then
8021 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8025 -- For the subprogram case, set proper convention for all homonyms
8026 -- in same scope and the same declarative part, i.e. the same
8027 -- compilation unit.
8030 Comp_Unit
:= Get_Source_Unit
(E
);
8031 Set_Convention_From_Pragma
(E
);
8033 -- Treat a pragma Import as an implicit body, and pragma import
8034 -- as implicit reference (for navigation in GPS).
8036 if Prag_Id
= Pragma_Import
then
8037 Generate_Reference
(E
, Id
, 'b');
8039 -- For exported entities we restrict the generation of references
8040 -- to entities exported to foreign languages since entities
8041 -- exported to Ada do not provide further information to GPS and
8042 -- add undesired references to the output of the gnatxref tool.
8044 elsif Prag_Id
= Pragma_Export
8045 and then Convention
(E
) /= Convention_Ada
8047 Generate_Reference
(E
, Id
, 'i');
8050 -- If the pragma comes from an aspect, it only applies to the
8051 -- given entity, not its homonyms.
8053 if From_Aspect_Specification
(N
) then
8054 if C
= Convention_Intrinsic
8055 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8057 if Is_Fixed_Point_Type
(Etype
(Ent
))
8058 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8059 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8062 ("no intrinsic operator available for this fixed-point "
8065 ("\use expression functions with the desired "
8066 & "conversions made explicit", N
);
8073 -- Otherwise Loop through the homonyms of the pragma argument's
8074 -- entity, an apply convention to those in the current scope.
8080 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8082 -- Ignore entry for which convention is already set
8084 if Has_Convention_Pragma
(E1
) then
8088 if Is_Subprogram
(E1
)
8089 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8091 and then not Relaxed_RM_Semantics
8093 Set_Has_Completion
(E
); -- to prevent cascaded error
8095 ("pragma% requires separate spec and must come before "
8099 -- Do not set the pragma on inherited operations or on formal
8102 if Comes_From_Source
(E1
)
8103 and then Comp_Unit
= Get_Source_Unit
(E1
)
8104 and then not Is_Formal_Subprogram
(E1
)
8105 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8106 N_Full_Type_Declaration
8108 if Present
(Alias
(E1
))
8109 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8112 ("cannot apply pragma% to non-local entity& declared#",
8116 Set_Convention_From_Pragma
(E1
);
8118 if Prag_Id
= Pragma_Import
then
8119 Generate_Reference
(E1
, Id
, 'b');
8127 end Process_Convention
;
8129 ----------------------------------------
8130 -- Process_Disable_Enable_Atomic_Sync --
8131 ----------------------------------------
8133 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8135 Check_No_Identifiers
;
8136 Check_At_Most_N_Arguments
(1);
8138 -- Modeled internally as
8139 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8144 Pragma_Argument_Associations
=> New_List
(
8145 Make_Pragma_Argument_Association
(Loc
,
8147 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8149 if Present
(Arg1
) then
8150 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8154 end Process_Disable_Enable_Atomic_Sync
;
8156 -------------------------------------------------
8157 -- Process_Extended_Import_Export_Internal_Arg --
8158 -------------------------------------------------
8160 procedure Process_Extended_Import_Export_Internal_Arg
8161 (Arg_Internal
: Node_Id
:= Empty
)
8164 if No
(Arg_Internal
) then
8165 Error_Pragma
("Internal parameter required for pragma%");
8168 if Nkind
(Arg_Internal
) = N_Identifier
then
8171 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8172 and then (Prag_Id
= Pragma_Import_Function
8174 Prag_Id
= Pragma_Export_Function
)
8180 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8183 Check_Arg_Is_Local_Name
(Arg_Internal
);
8184 end Process_Extended_Import_Export_Internal_Arg
;
8186 --------------------------------------------------
8187 -- Process_Extended_Import_Export_Object_Pragma --
8188 --------------------------------------------------
8190 procedure Process_Extended_Import_Export_Object_Pragma
8191 (Arg_Internal
: Node_Id
;
8192 Arg_External
: Node_Id
;
8198 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8199 Def_Id
:= Entity
(Arg_Internal
);
8201 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8203 ("pragma% must designate an object", Arg_Internal
);
8206 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8208 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8211 ("previous Common/Psect_Object applies, pragma % not permitted",
8215 if Rep_Item_Too_Late
(Def_Id
, N
) then
8219 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8221 if Present
(Arg_Size
) then
8222 Check_Arg_Is_External_Name
(Arg_Size
);
8225 -- Export_Object case
8227 if Prag_Id
= Pragma_Export_Object
then
8228 if not Is_Library_Level_Entity
(Def_Id
) then
8230 ("argument for pragma% must be library level entity",
8234 if Ekind
(Current_Scope
) = E_Generic_Package
then
8235 Error_Pragma
("pragma& cannot appear in a generic unit");
8238 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8240 ("exported object must have compile time known size",
8244 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8245 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8247 Set_Exported
(Def_Id
, Arg_Internal
);
8250 -- Import_Object case
8253 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8255 ("cannot use pragma% for task/protected object",
8259 if Ekind
(Def_Id
) = E_Constant
then
8261 ("cannot import a constant", Arg_Internal
);
8264 if Warn_On_Export_Import
8265 and then Has_Discriminants
(Etype
(Def_Id
))
8268 ("imported value must be initialized??", Arg_Internal
);
8271 if Warn_On_Export_Import
8272 and then Is_Access_Type
(Etype
(Def_Id
))
8275 ("cannot import object of an access type??", Arg_Internal
);
8278 if Warn_On_Export_Import
8279 and then Is_Imported
(Def_Id
)
8281 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8283 -- Check for explicit initialization present. Note that an
8284 -- initialization generated by the code generator, e.g. for an
8285 -- access type, does not count here.
8287 elsif Present
(Expression
(Parent
(Def_Id
)))
8290 (Original_Node
(Expression
(Parent
(Def_Id
))))
8292 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8294 ("imported entities cannot be initialized (RM B.1(24))",
8295 "\no initialization allowed for & declared#", Arg1
);
8297 Set_Imported
(Def_Id
);
8298 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8301 end Process_Extended_Import_Export_Object_Pragma
;
8303 ------------------------------------------------------
8304 -- Process_Extended_Import_Export_Subprogram_Pragma --
8305 ------------------------------------------------------
8307 procedure Process_Extended_Import_Export_Subprogram_Pragma
8308 (Arg_Internal
: Node_Id
;
8309 Arg_External
: Node_Id
;
8310 Arg_Parameter_Types
: Node_Id
;
8311 Arg_Result_Type
: Node_Id
:= Empty
;
8312 Arg_Mechanism
: Node_Id
;
8313 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8319 Ambiguous
: Boolean;
8322 function Same_Base_Type
8324 Formal
: Entity_Id
) return Boolean;
8325 -- Determines if Ptype references the type of Formal. Note that only
8326 -- the base types need to match according to the spec. Ptype here is
8327 -- the argument from the pragma, which is either a type name, or an
8328 -- access attribute.
8330 --------------------
8331 -- Same_Base_Type --
8332 --------------------
8334 function Same_Base_Type
8336 Formal
: Entity_Id
) return Boolean
8338 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8342 -- Case where pragma argument is typ'Access
8344 if Nkind
(Ptype
) = N_Attribute_Reference
8345 and then Attribute_Name
(Ptype
) = Name_Access
8347 Pref
:= Prefix
(Ptype
);
8350 if not Is_Entity_Name
(Pref
)
8351 or else Entity
(Pref
) = Any_Type
8356 -- We have a match if the corresponding argument is of an
8357 -- anonymous access type, and its designated type matches the
8358 -- type of the prefix of the access attribute
8360 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8361 and then Base_Type
(Entity
(Pref
)) =
8362 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8364 -- Case where pragma argument is a type name
8369 if not Is_Entity_Name
(Ptype
)
8370 or else Entity
(Ptype
) = Any_Type
8375 -- We have a match if the corresponding argument is of the type
8376 -- given in the pragma (comparing base types)
8378 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8382 -- Start of processing for
8383 -- Process_Extended_Import_Export_Subprogram_Pragma
8386 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8390 -- Loop through homonyms (overloadings) of the entity
8392 Hom_Id
:= Entity
(Arg_Internal
);
8393 while Present
(Hom_Id
) loop
8394 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8396 -- We need a subprogram in the current scope
8398 if not Is_Subprogram
(Def_Id
)
8399 or else Scope
(Def_Id
) /= Current_Scope
8406 -- Pragma cannot apply to subprogram body
8408 if Is_Subprogram
(Def_Id
)
8409 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8413 ("pragma% requires separate spec and must come before "
8417 -- Test result type if given, note that the result type
8418 -- parameter can only be present for the function cases.
8420 if Present
(Arg_Result_Type
)
8421 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8425 elsif Etype
(Def_Id
) /= Standard_Void_Type
8426 and then Nam_In
(Pname
, Name_Export_Procedure
,
8427 Name_Import_Procedure
)
8431 -- Test parameter types if given. Note that this parameter has
8432 -- not been analyzed (and must not be, since it is semantic
8433 -- nonsense), so we get it as the parser left it.
8435 elsif Present
(Arg_Parameter_Types
) then
8436 Check_Matching_Types
: declare
8441 Formal
:= First_Formal
(Def_Id
);
8443 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8444 if Present
(Formal
) then
8448 -- A list of one type, e.g. (List) is parsed as a
8449 -- parenthesized expression.
8451 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8452 and then Paren_Count
(Arg_Parameter_Types
) = 1
8455 or else Present
(Next_Formal
(Formal
))
8460 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8463 -- A list of more than one type is parsed as a aggregate
8465 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8466 and then Paren_Count
(Arg_Parameter_Types
) = 0
8468 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8469 while Present
(Ptype
) or else Present
(Formal
) loop
8472 or else not Same_Base_Type
(Ptype
, Formal
)
8477 Next_Formal
(Formal
);
8482 -- Anything else is of the wrong form
8486 ("wrong form for Parameter_Types parameter",
8487 Arg_Parameter_Types
);
8489 end Check_Matching_Types
;
8492 -- Match is now False if the entry we found did not match
8493 -- either a supplied Parameter_Types or Result_Types argument
8499 -- Ambiguous case, the flag Ambiguous shows if we already
8500 -- detected this and output the initial messages.
8503 if not Ambiguous
then
8505 Error_Msg_Name_1
:= Pname
;
8507 ("pragma% does not uniquely identify subprogram!",
8509 Error_Msg_Sloc
:= Sloc
(Ent
);
8510 Error_Msg_N
("matching subprogram #!", N
);
8514 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8515 Error_Msg_N
("matching subprogram #!", N
);
8520 Hom_Id
:= Homonym
(Hom_Id
);
8523 -- See if we found an entry
8526 if not Ambiguous
then
8527 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8529 ("pragma% cannot be given for generic subprogram");
8532 ("pragma% does not identify local subprogram");
8539 -- Import pragmas must be for imported entities
8541 if Prag_Id
= Pragma_Import_Function
8543 Prag_Id
= Pragma_Import_Procedure
8545 Prag_Id
= Pragma_Import_Valued_Procedure
8547 if not Is_Imported
(Ent
) then
8549 ("pragma Import or Interface must precede pragma%");
8552 -- Here we have the Export case which can set the entity as exported
8554 -- But does not do so if the specified external name is null, since
8555 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8556 -- compatible) to request no external name.
8558 elsif Nkind
(Arg_External
) = N_String_Literal
8559 and then String_Length
(Strval
(Arg_External
)) = 0
8563 -- In all other cases, set entity as exported
8566 Set_Exported
(Ent
, Arg_Internal
);
8569 -- Special processing for Valued_Procedure cases
8571 if Prag_Id
= Pragma_Import_Valued_Procedure
8573 Prag_Id
= Pragma_Export_Valued_Procedure
8575 Formal
:= First_Formal
(Ent
);
8578 Error_Pragma
("at least one parameter required for pragma%");
8580 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8581 Error_Pragma
("first parameter must have mode out for pragma%");
8584 Set_Is_Valued_Procedure
(Ent
);
8588 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8590 -- Process Result_Mechanism argument if present. We have already
8591 -- checked that this is only allowed for the function case.
8593 if Present
(Arg_Result_Mechanism
) then
8594 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8597 -- Process Mechanism parameter if present. Note that this parameter
8598 -- is not analyzed, and must not be analyzed since it is semantic
8599 -- nonsense, so we get it in exactly as the parser left it.
8601 if Present
(Arg_Mechanism
) then
8609 -- A single mechanism association without a formal parameter
8610 -- name is parsed as a parenthesized expression. All other
8611 -- cases are parsed as aggregates, so we rewrite the single
8612 -- parameter case as an aggregate for consistency.
8614 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8615 and then Paren_Count
(Arg_Mechanism
) = 1
8617 Rewrite
(Arg_Mechanism
,
8618 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8619 Expressions
=> New_List
(
8620 Relocate_Node
(Arg_Mechanism
))));
8623 -- Case of only mechanism name given, applies to all formals
8625 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8626 Formal
:= First_Formal
(Ent
);
8627 while Present
(Formal
) loop
8628 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8629 Next_Formal
(Formal
);
8632 -- Case of list of mechanism associations given
8635 if Null_Record_Present
(Arg_Mechanism
) then
8637 ("inappropriate form for Mechanism parameter",
8641 -- Deal with positional ones first
8643 Formal
:= First_Formal
(Ent
);
8645 if Present
(Expressions
(Arg_Mechanism
)) then
8646 Mname
:= First
(Expressions
(Arg_Mechanism
));
8647 while Present
(Mname
) loop
8650 ("too many mechanism associations", Mname
);
8653 Set_Mechanism_Value
(Formal
, Mname
);
8654 Next_Formal
(Formal
);
8659 -- Deal with named entries
8661 if Present
(Component_Associations
(Arg_Mechanism
)) then
8662 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8663 while Present
(Massoc
) loop
8664 Choice
:= First
(Choices
(Massoc
));
8666 if Nkind
(Choice
) /= N_Identifier
8667 or else Present
(Next
(Choice
))
8670 ("incorrect form for mechanism association",
8674 Formal
:= First_Formal
(Ent
);
8678 ("parameter name & not present", Choice
);
8681 if Chars
(Choice
) = Chars
(Formal
) then
8683 (Formal
, Expression
(Massoc
));
8685 -- Set entity on identifier (needed by ASIS)
8687 Set_Entity
(Choice
, Formal
);
8692 Next_Formal
(Formal
);
8701 end Process_Extended_Import_Export_Subprogram_Pragma
;
8703 --------------------------
8704 -- Process_Generic_List --
8705 --------------------------
8707 procedure Process_Generic_List
is
8712 Check_No_Identifiers
;
8713 Check_At_Least_N_Arguments
(1);
8715 -- Check all arguments are names of generic units or instances
8718 while Present
(Arg
) loop
8719 Exp
:= Get_Pragma_Arg
(Arg
);
8722 if not Is_Entity_Name
(Exp
)
8724 (not Is_Generic_Instance
(Entity
(Exp
))
8726 not Is_Generic_Unit
(Entity
(Exp
)))
8729 ("pragma% argument must be name of generic unit/instance",
8735 end Process_Generic_List
;
8737 ------------------------------------
8738 -- Process_Import_Predefined_Type --
8739 ------------------------------------
8741 procedure Process_Import_Predefined_Type
is
8742 Loc
: constant Source_Ptr
:= Sloc
(N
);
8744 Ftyp
: Node_Id
:= Empty
;
8750 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8752 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8753 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8757 Ftyp
:= Node
(Elmt
);
8759 if Present
(Ftyp
) then
8761 -- Don't build a derived type declaration, because predefined C
8762 -- types have no declaration anywhere, so cannot really be named.
8763 -- Instead build a full type declaration, starting with an
8764 -- appropriate type definition is built
8766 if Is_Floating_Point_Type
(Ftyp
) then
8767 Def
:= Make_Floating_Point_Definition
(Loc
,
8768 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8769 Make_Real_Range_Specification
(Loc
,
8770 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8771 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8773 -- Should never have a predefined type we cannot handle
8776 raise Program_Error
;
8779 -- Build and insert a Full_Type_Declaration, which will be
8780 -- analyzed as soon as this list entry has been analyzed.
8782 Decl
:= Make_Full_Type_Declaration
(Loc
,
8783 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8784 Type_Definition
=> Def
);
8786 Insert_After
(N
, Decl
);
8787 Mark_Rewrite_Insertion
(Decl
);
8790 Error_Pragma_Arg
("no matching type found for pragma%",
8793 end Process_Import_Predefined_Type
;
8795 ---------------------------------
8796 -- Process_Import_Or_Interface --
8797 ---------------------------------
8799 procedure Process_Import_Or_Interface
is
8805 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8806 -- pragma Import (Entity, "external name");
8808 if Relaxed_RM_Semantics
8809 and then Arg_Count
= 2
8810 and then Prag_Id
= Pragma_Import
8811 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8814 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8817 if not Is_Entity_Name
(Def_Id
) then
8818 Error_Pragma_Arg
("entity name required", Arg1
);
8821 Def_Id
:= Entity
(Def_Id
);
8822 Kill_Size_Check_Code
(Def_Id
);
8823 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8826 Process_Convention
(C
, Def_Id
);
8828 -- A pragma that applies to a Ghost entity becomes Ghost for the
8829 -- purposes of legality checks and removal of ignored Ghost code.
8831 Mark_Ghost_Pragma
(N
, Def_Id
);
8832 Kill_Size_Check_Code
(Def_Id
);
8833 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8836 -- Various error checks
8838 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8840 -- We do not permit Import to apply to a renaming declaration
8842 if Present
(Renamed_Object
(Def_Id
)) then
8844 ("pragma% not allowed for object renaming", Arg2
);
8846 -- User initialization is not allowed for imported object, but
8847 -- the object declaration may contain a default initialization,
8848 -- that will be discarded. Note that an explicit initialization
8849 -- only counts if it comes from source, otherwise it is simply
8850 -- the code generator making an implicit initialization explicit.
8852 elsif Present
(Expression
(Parent
(Def_Id
)))
8853 and then Comes_From_Source
8854 (Original_Node
(Expression
(Parent
(Def_Id
))))
8856 -- Set imported flag to prevent cascaded errors
8858 Set_Is_Imported
(Def_Id
);
8860 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8862 ("no initialization allowed for declaration of& #",
8863 "\imported entities cannot be initialized (RM B.1(24))",
8867 -- If the pragma comes from an aspect specification the
8868 -- Is_Imported flag has already been set.
8870 if not From_Aspect_Specification
(N
) then
8871 Set_Imported
(Def_Id
);
8874 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8876 -- Note that we do not set Is_Public here. That's because we
8877 -- only want to set it if there is no address clause, and we
8878 -- don't know that yet, so we delay that processing till
8881 -- pragma Import completes deferred constants
8883 if Ekind
(Def_Id
) = E_Constant
then
8884 Set_Has_Completion
(Def_Id
);
8887 -- It is not possible to import a constant of an unconstrained
8888 -- array type (e.g. string) because there is no simple way to
8889 -- write a meaningful subtype for it.
8891 if Is_Array_Type
(Etype
(Def_Id
))
8892 and then not Is_Constrained
(Etype
(Def_Id
))
8895 ("imported constant& must have a constrained subtype",
8900 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8902 -- If the name is overloaded, pragma applies to all of the denoted
8903 -- entities in the same declarative part, unless the pragma comes
8904 -- from an aspect specification or was generated by the compiler
8905 -- (such as for pragma Provide_Shift_Operators).
8908 while Present
(Hom_Id
) loop
8910 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8912 -- Ignore inherited subprograms because the pragma will apply
8913 -- to the parent operation, which is the one called.
8915 if Is_Overloadable
(Def_Id
)
8916 and then Present
(Alias
(Def_Id
))
8920 -- If it is not a subprogram, it must be in an outer scope and
8921 -- pragma does not apply.
8923 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8926 -- The pragma does not apply to primitives of interfaces
8928 elsif Is_Dispatching_Operation
(Def_Id
)
8929 and then Present
(Find_Dispatching_Type
(Def_Id
))
8930 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8934 -- Verify that the homonym is in the same declarative part (not
8935 -- just the same scope). If the pragma comes from an aspect
8936 -- specification we know that it is part of the declaration.
8938 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8939 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8940 and then not From_Aspect_Specification
(N
)
8945 -- If the pragma comes from an aspect specification the
8946 -- Is_Imported flag has already been set.
8948 if not From_Aspect_Specification
(N
) then
8949 Set_Imported
(Def_Id
);
8952 -- Reject an Import applied to an abstract subprogram
8954 if Is_Subprogram
(Def_Id
)
8955 and then Is_Abstract_Subprogram
(Def_Id
)
8957 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8959 ("cannot import abstract subprogram& declared#",
8963 -- Special processing for Convention_Intrinsic
8965 if C
= Convention_Intrinsic
then
8967 -- Link_Name argument not allowed for intrinsic
8971 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8973 -- If no external name is present, then check that this
8974 -- is a valid intrinsic subprogram. If an external name
8975 -- is present, then this is handled by the back end.
8978 Check_Intrinsic_Subprogram
8979 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8983 -- Verify that the subprogram does not have a completion
8984 -- through a renaming declaration. For other completions the
8985 -- pragma appears as a too late representation.
8988 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8992 and then Nkind
(Decl
) = N_Subprogram_Declaration
8993 and then Present
(Corresponding_Body
(Decl
))
8994 and then Nkind
(Unit_Declaration_Node
8995 (Corresponding_Body
(Decl
))) =
8996 N_Subprogram_Renaming_Declaration
8998 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9000 ("cannot import&, renaming already provided for "
9001 & "declaration #", N
, Def_Id
);
9005 -- If the pragma comes from an aspect specification, there
9006 -- must be an Import aspect specified as well. In the rare
9007 -- case where Import is set to False, the suprogram needs to
9008 -- have a local completion.
9011 Imp_Aspect
: constant Node_Id
:=
9012 Find_Aspect
(Def_Id
, Aspect_Import
);
9016 if Present
(Imp_Aspect
)
9017 and then Present
(Expression
(Imp_Aspect
))
9019 Expr
:= Expression
(Imp_Aspect
);
9020 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9022 if Is_Entity_Name
(Expr
)
9023 and then Entity
(Expr
) = Standard_True
9025 Set_Has_Completion
(Def_Id
);
9028 -- If there is no expression, the default is True, as for
9029 -- all boolean aspects. Same for the older pragma.
9032 Set_Has_Completion
(Def_Id
);
9036 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9039 if Is_Compilation_Unit
(Hom_Id
) then
9041 -- Its possible homonyms are not affected by the pragma.
9042 -- Such homonyms might be present in the context of other
9043 -- units being compiled.
9047 elsif From_Aspect_Specification
(N
) then
9050 -- If the pragma was created by the compiler, then we don't
9051 -- want it to apply to other homonyms. This kind of case can
9052 -- occur when using pragma Provide_Shift_Operators, which
9053 -- generates implicit shift and rotate operators with Import
9054 -- pragmas that might apply to earlier explicit or implicit
9055 -- declarations marked with Import (for example, coming from
9056 -- an earlier pragma Provide_Shift_Operators for another type),
9057 -- and we don't generally want other homonyms being treated
9058 -- as imported or the pragma flagged as an illegal duplicate.
9060 elsif not Comes_From_Source
(N
) then
9064 Hom_Id
:= Homonym
(Hom_Id
);
9068 -- Import a CPP class
9070 elsif C
= Convention_CPP
9071 and then (Is_Record_Type
(Def_Id
)
9072 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9074 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9075 if Present
(Full_View
(Def_Id
)) then
9076 Def_Id
:= Full_View
(Def_Id
);
9080 ("cannot import 'C'P'P type before full declaration seen",
9081 Get_Pragma_Arg
(Arg2
));
9083 -- Although we have reported the error we decorate it as
9084 -- CPP_Class to avoid reporting spurious errors
9086 Set_Is_CPP_Class
(Def_Id
);
9091 -- Types treated as CPP classes must be declared limited (note:
9092 -- this used to be a warning but there is no real benefit to it
9093 -- since we did effectively intend to treat the type as limited
9096 if not Is_Limited_Type
(Def_Id
) then
9098 ("imported 'C'P'P type must be limited",
9099 Get_Pragma_Arg
(Arg2
));
9102 if Etype
(Def_Id
) /= Def_Id
9103 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9105 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9108 Set_Is_CPP_Class
(Def_Id
);
9110 -- Imported CPP types must not have discriminants (because C++
9111 -- classes do not have discriminants).
9113 if Has_Discriminants
(Def_Id
) then
9115 ("imported 'C'P'P type cannot have discriminants",
9116 First
(Discriminant_Specifications
9117 (Declaration_Node
(Def_Id
))));
9120 -- Check that components of imported CPP types do not have default
9121 -- expressions. For private types this check is performed when the
9122 -- full view is analyzed (see Process_Full_View).
9124 if not Is_Private_Type
(Def_Id
) then
9125 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9128 -- Import a CPP exception
9130 elsif C
= Convention_CPP
9131 and then Ekind
(Def_Id
) = E_Exception
9135 ("'External_'Name arguments is required for 'Cpp exception",
9138 -- As only a string is allowed, Check_Arg_Is_External_Name
9141 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9144 if Present
(Arg4
) then
9146 ("Link_Name argument not allowed for imported Cpp exception",
9150 -- Do not call Set_Interface_Name as the name of the exception
9151 -- shouldn't be modified (and in particular it shouldn't be
9152 -- the External_Name). For exceptions, the External_Name is the
9153 -- name of the RTTI structure.
9155 -- ??? Emit an error if pragma Import/Export_Exception is present
9157 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9159 Check_Arg_Count
(3);
9160 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9162 Process_Import_Predefined_Type
;
9166 ("second argument of pragma% must be object, subprogram "
9167 & "or incomplete type",
9171 -- If this pragma applies to a compilation unit, then the unit, which
9172 -- is a subprogram, does not require (or allow) a body. We also do
9173 -- not need to elaborate imported procedures.
9175 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9177 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9179 Set_Body_Required
(Cunit
, False);
9182 end Process_Import_Or_Interface
;
9184 --------------------
9185 -- Process_Inline --
9186 --------------------
9188 procedure Process_Inline
(Status
: Inline_Status
) is
9195 Ghost_Error_Posted
: Boolean := False;
9196 -- Flag set when an error concerning the illegal mix of Ghost and
9197 -- non-Ghost subprograms is emitted.
9199 Ghost_Id
: Entity_Id
:= Empty
;
9200 -- The entity of the first Ghost subprogram encountered while
9201 -- processing the arguments of the pragma.
9203 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9204 -- Verify the placement of pragma Inline_Always with respect to the
9205 -- initial declaration of subprogram Spec_Id.
9207 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9208 -- Returns True if it can be determined at this stage that inlining
9209 -- is not possible, for example if the body is available and contains
9210 -- exception handlers, we prevent inlining, since otherwise we can
9211 -- get undefined symbols at link time. This function also emits a
9212 -- warning if the pragma appears too late.
9214 -- ??? is business with link symbols still valid, or does it relate
9215 -- to front end ZCX which is being phased out ???
9217 procedure Make_Inline
(Subp
: Entity_Id
);
9218 -- Subp is the defining unit name of the subprogram declaration. If
9219 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9220 -- the corresponding body, if there is one present.
9222 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9223 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9224 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9226 -----------------------------------
9227 -- Check_Inline_Always_Placement --
9228 -----------------------------------
9230 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9231 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9233 function Compilation_Unit_OK
return Boolean;
9234 pragma Inline
(Compilation_Unit_OK
);
9235 -- Determine whether pragma Inline_Always applies to a compatible
9236 -- compilation unit denoted by Spec_Id.
9238 function Declarative_List_OK
return Boolean;
9239 pragma Inline
(Declarative_List_OK
);
9240 -- Determine whether the initial declaration of subprogram Spec_Id
9241 -- and the pragma appear in compatible declarative lists.
9243 function Subprogram_Body_OK
return Boolean;
9244 pragma Inline
(Subprogram_Body_OK
);
9245 -- Determine whether pragma Inline_Always applies to a compatible
9246 -- subprogram body denoted by Spec_Id.
9248 -------------------------
9249 -- Compilation_Unit_OK --
9250 -------------------------
9252 function Compilation_Unit_OK
return Boolean is
9253 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9256 -- The pragma appears after the initial declaration of a
9257 -- compilation unit.
9259 -- procedure Comp_Unit;
9260 -- pragma Inline_Always (Comp_Unit);
9262 -- Note that for compatibility reasons, the following case is
9265 -- procedure Stand_Alone_Body_Comp_Unit is
9267 -- end Stand_Alone_Body_Comp_Unit;
9268 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9271 Nkind
(Comp_Unit
) = N_Compilation_Unit
9272 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9273 and then Is_List_Member
(N
)
9274 and then List_Containing
(N
) =
9275 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9276 end Compilation_Unit_OK
;
9278 -------------------------
9279 -- Declarative_List_OK --
9280 -------------------------
9282 function Declarative_List_OK
return Boolean is
9283 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9285 Init_Decl
: Node_Id
;
9286 Init_List
: List_Id
;
9287 Prag_List
: List_Id
;
9290 -- Determine the proper initial declaration. In general this is
9291 -- the declaration node of the subprogram except when the input
9292 -- denotes a generic instantiation.
9294 -- procedure Inst is new Gen;
9295 -- pragma Inline_Always (Inst);
9297 -- In this case the original subprogram is moved inside an
9298 -- anonymous package while pragma Inline_Always remains at the
9299 -- level of the anonymous package. Use the declaration of the
9300 -- package because it reflects the placement of the original
9303 -- package Anon_Pack is
9304 -- procedure Inst is ... end Inst; -- original
9307 -- procedure Inst renames Anon_Pack.Inst;
9308 -- pragma Inline_Always (Inst);
9310 if Is_Generic_Instance
(Spec_Id
) then
9311 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9312 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9314 Init_Decl
:= Spec_Decl
;
9317 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9318 Init_List
:= List_Containing
(Init_Decl
);
9319 Prag_List
:= List_Containing
(N
);
9321 -- The pragma and then initial declaration appear within the
9322 -- same declarative list.
9324 if Init_List
= Prag_List
then
9327 -- A special case of the above is when both the pragma and
9328 -- the initial declaration appear in different lists of a
9329 -- package spec, protected definition, or a task definition.
9334 -- pragma Inline_Always (Proc);
9337 elsif Nkind_In
(Context
, N_Package_Specification
,
9338 N_Protected_Definition
,
9340 and then Init_List
= Visible_Declarations
(Context
)
9341 and then Prag_List
= Private_Declarations
(Context
)
9348 end Declarative_List_OK
;
9350 ------------------------
9351 -- Subprogram_Body_OK --
9352 ------------------------
9354 function Subprogram_Body_OK
return Boolean is
9355 Body_Decl
: Node_Id
;
9358 -- The pragma appears within the declarative list of a stand-
9359 -- alone subprogram body.
9361 -- procedure Stand_Alone_Body is
9362 -- pragma Inline_Always (Stand_Alone_Body);
9365 -- end Stand_Alone_Body;
9367 -- The compiler creates a dummy spec in this case, however the
9368 -- pragma remains within the declarative list of the body.
9370 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9371 and then not Comes_From_Source
(Spec_Decl
)
9372 and then Present
(Corresponding_Body
(Spec_Decl
))
9375 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9377 if Present
(Declarations
(Body_Decl
))
9378 and then Is_List_Member
(N
)
9379 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9386 end Subprogram_Body_OK
;
9388 -- Start of processing for Check_Inline_Always_Placement
9391 -- This check is relevant only for pragma Inline_Always
9393 if Pname
/= Name_Inline_Always
then
9396 -- Nothing to do when the pragma is internally generated on the
9397 -- assumption that it is properly placed.
9399 elsif not Comes_From_Source
(N
) then
9402 -- Nothing to do for internally generated subprograms that act
9403 -- as accidental homonyms of a source subprogram being inlined.
9405 elsif not Comes_From_Source
(Spec_Id
) then
9408 -- Nothing to do for generic formal subprograms that act as
9409 -- homonyms of another source subprogram being inlined.
9411 elsif Is_Formal_Subprogram
(Spec_Id
) then
9414 elsif Compilation_Unit_OK
9415 or else Declarative_List_OK
9416 or else Subprogram_Body_OK
9421 -- At this point it is known that the pragma applies to or appears
9422 -- within a completing body, a completing stub, or a subunit.
9424 Error_Msg_Name_1
:= Pname
;
9425 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9426 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9429 ("pragma % must appear on initial declaration of subprogram "
9430 & "% defined #", N
);
9431 end Check_Inline_Always_Placement
;
9433 ---------------------------
9434 -- Inlining_Not_Possible --
9435 ---------------------------
9437 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9438 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9442 if Nkind
(Decl
) = N_Subprogram_Body
then
9443 Stats
:= Handled_Statement_Sequence
(Decl
);
9444 return Present
(Exception_Handlers
(Stats
))
9445 or else Present
(At_End_Proc
(Stats
));
9447 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9448 and then Present
(Corresponding_Body
(Decl
))
9450 if Analyzed
(Corresponding_Body
(Decl
)) then
9451 Error_Msg_N
("pragma appears too late, ignored??", N
);
9454 -- If the subprogram is a renaming as body, the body is just a
9455 -- call to the renamed subprogram, and inlining is trivially
9459 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9460 N_Subprogram_Renaming_Declaration
9466 Handled_Statement_Sequence
9467 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9470 Present
(Exception_Handlers
(Stats
))
9471 or else Present
(At_End_Proc
(Stats
));
9475 -- If body is not available, assume the best, the check is
9476 -- performed again when compiling enclosing package bodies.
9480 end Inlining_Not_Possible
;
9486 procedure Make_Inline
(Subp
: Entity_Id
) is
9487 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9488 Inner_Subp
: Entity_Id
:= Subp
;
9491 -- Ignore if bad type, avoid cascaded error
9493 if Etype
(Subp
) = Any_Type
then
9497 -- If inlining is not possible, for now do not treat as an error
9499 elsif Status
/= Suppressed
9500 and then Front_End_Inlining
9501 and then Inlining_Not_Possible
(Subp
)
9506 -- Here we have a candidate for inlining, but we must exclude
9507 -- derived operations. Otherwise we would end up trying to inline
9508 -- a phantom declaration, and the result would be to drag in a
9509 -- body which has no direct inlining associated with it. That
9510 -- would not only be inefficient but would also result in the
9511 -- backend doing cross-unit inlining in cases where it was
9512 -- definitely inappropriate to do so.
9514 -- However, a simple Comes_From_Source test is insufficient, since
9515 -- we do want to allow inlining of generic instances which also do
9516 -- not come from source. We also need to recognize specs generated
9517 -- by the front-end for bodies that carry the pragma. Finally,
9518 -- predefined operators do not come from source but are not
9519 -- inlineable either.
9521 elsif Is_Generic_Instance
(Subp
)
9522 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9526 elsif not Comes_From_Source
(Subp
)
9527 and then Scope
(Subp
) /= Standard_Standard
9533 -- The referenced entity must either be the enclosing entity, or
9534 -- an entity declared within the current open scope.
9536 if Present
(Scope
(Subp
))
9537 and then Scope
(Subp
) /= Current_Scope
9538 and then Subp
/= Current_Scope
9541 ("argument of% must be entity in current scope", Assoc
);
9545 -- Processing for procedure, operator or function. If subprogram
9546 -- is aliased (as for an instance) indicate that the renamed
9547 -- entity (if declared in the same unit) is inlined.
9548 -- If this is the anonymous subprogram created for a subprogram
9549 -- instance, the inlining applies to it directly. Otherwise we
9550 -- retrieve it as the alias of the visible subprogram instance.
9552 if Is_Subprogram
(Subp
) then
9554 -- Ensure that pragma Inline_Always is associated with the
9555 -- initial declaration of the subprogram.
9557 Check_Inline_Always_Placement
(Subp
);
9559 if Is_Wrapper_Package
(Scope
(Subp
)) then
9562 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9565 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9566 Set_Inline_Flags
(Inner_Subp
);
9568 Decl
:= Parent
(Parent
(Inner_Subp
));
9570 if Nkind
(Decl
) = N_Subprogram_Declaration
9571 and then Present
(Corresponding_Body
(Decl
))
9573 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9575 elsif Is_Generic_Instance
(Subp
)
9576 and then Comes_From_Source
(Subp
)
9578 -- Indicate that the body needs to be created for
9579 -- inlining subsequent calls. The instantiation node
9580 -- follows the declaration of the wrapper package
9581 -- created for it. The subprogram that requires the
9582 -- body is the anonymous one in the wrapper package.
9584 if Scope
(Subp
) /= Standard_Standard
9586 Need_Subprogram_Instance_Body
9587 (Next
(Unit_Declaration_Node
9588 (Scope
(Alias
(Subp
)))), Subp
)
9593 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9594 -- appear in a formal part to apply to a formal subprogram.
9595 -- Do not apply check within an instance or a formal package
9596 -- the test will have been applied to the original generic.
9598 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9599 and then List_Containing
(Decl
) = List_Containing
(N
)
9600 and then not In_Instance
9603 ("Inline cannot apply to a formal subprogram", N
);
9605 -- If Subp is a renaming, it is the renamed entity that
9606 -- will appear in any call, and be inlined. However, for
9607 -- ASIS uses it is convenient to indicate that the renaming
9608 -- itself is an inlined subprogram, so that some gnatcheck
9609 -- rules can be applied in the absence of expansion.
9611 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9612 Set_Inline_Flags
(Subp
);
9618 -- For a generic subprogram set flag as well, for use at the point
9619 -- of instantiation, to determine whether the body should be
9622 elsif Is_Generic_Subprogram
(Subp
) then
9623 Set_Inline_Flags
(Subp
);
9626 -- Literals are by definition inlined
9628 elsif Kind
= E_Enumeration_Literal
then
9631 -- Anything else is an error
9635 ("expect subprogram name for pragma%", Assoc
);
9639 ----------------------
9640 -- Set_Inline_Flags --
9641 ----------------------
9643 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9645 -- First set the Has_Pragma_XXX flags and issue the appropriate
9646 -- errors and warnings for suspicious combinations.
9648 if Prag_Id
= Pragma_No_Inline
then
9649 if Has_Pragma_Inline_Always
(Subp
) then
9651 ("Inline_Always and No_Inline are mutually exclusive", N
);
9652 elsif Has_Pragma_Inline
(Subp
) then
9654 ("Inline and No_Inline both specified for& ??",
9655 N
, Entity
(Subp_Id
));
9658 Set_Has_Pragma_No_Inline
(Subp
);
9660 if Prag_Id
= Pragma_Inline_Always
then
9661 if Has_Pragma_No_Inline
(Subp
) then
9663 ("Inline_Always and No_Inline are mutually exclusive",
9667 Set_Has_Pragma_Inline_Always
(Subp
);
9669 if Has_Pragma_No_Inline
(Subp
) then
9671 ("Inline and No_Inline both specified for& ??",
9672 N
, Entity
(Subp_Id
));
9676 Set_Has_Pragma_Inline
(Subp
);
9679 -- Then adjust the Is_Inlined flag. It can never be set if the
9680 -- subprogram is subject to pragma No_Inline.
9684 Set_Is_Inlined
(Subp
, False);
9690 if not Has_Pragma_No_Inline
(Subp
) then
9691 Set_Is_Inlined
(Subp
, True);
9695 -- A pragma that applies to a Ghost entity becomes Ghost for the
9696 -- purposes of legality checks and removal of ignored Ghost code.
9698 Mark_Ghost_Pragma
(N
, Subp
);
9700 -- Capture the entity of the first Ghost subprogram being
9701 -- processed for error detection purposes.
9703 if Is_Ghost_Entity
(Subp
) then
9704 if No
(Ghost_Id
) then
9708 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9709 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9711 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9712 Ghost_Error_Posted
:= True;
9714 Error_Msg_Name_1
:= Pname
;
9716 ("pragma % cannot mention ghost and non-ghost subprograms",
9719 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9720 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9722 Error_Msg_Sloc
:= Sloc
(Subp
);
9723 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9725 end Set_Inline_Flags
;
9727 -- Start of processing for Process_Inline
9730 Check_No_Identifiers
;
9731 Check_At_Least_N_Arguments
(1);
9733 if Status
= Enabled
then
9734 Inline_Processing_Required
:= True;
9738 while Present
(Assoc
) loop
9739 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9743 if Is_Entity_Name
(Subp_Id
) then
9744 Subp
:= Entity
(Subp_Id
);
9746 if Subp
= Any_Id
then
9748 -- If previous error, avoid cascaded errors
9750 Check_Error_Detected
;
9756 -- For the pragma case, climb homonym chain. This is
9757 -- what implements allowing the pragma in the renaming
9758 -- case, with the result applying to the ancestors, and
9759 -- also allows Inline to apply to all previous homonyms.
9761 if not From_Aspect_Specification
(N
) then
9762 while Present
(Homonym
(Subp
))
9763 and then Scope
(Homonym
(Subp
)) = Current_Scope
9765 Make_Inline
(Homonym
(Subp
));
9766 Subp
:= Homonym
(Subp
);
9773 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9779 -- If the context is a package declaration, the pragma indicates
9780 -- that inlining will require the presence of the corresponding
9781 -- body. (this may be further refined).
9784 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9785 N_Package_Declaration
9787 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9791 ----------------------------
9792 -- Process_Interface_Name --
9793 ----------------------------
9795 procedure Process_Interface_Name
9796 (Subprogram_Def
: Entity_Id
;
9803 String_Val
: String_Id
;
9805 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9806 -- SN is a string literal node for an interface name. This routine
9807 -- performs some minimal checks that the name is reasonable. In
9808 -- particular that no spaces or other obviously incorrect characters
9809 -- appear. This is only a warning, since any characters are allowed.
9811 ----------------------------------
9812 -- Check_Form_Of_Interface_Name --
9813 ----------------------------------
9815 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9816 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9817 SL
: constant Nat
:= String_Length
(S
);
9822 Error_Msg_N
("interface name cannot be null string", SN
);
9825 for J
in 1 .. SL
loop
9826 C
:= Get_String_Char
(S
, J
);
9828 -- Look for dubious character and issue unconditional warning.
9829 -- Definitely dubious if not in character range.
9831 if not In_Character_Range
(C
)
9833 -- Commas, spaces and (back)slashes are dubious
9835 or else Get_Character
(C
) = ','
9836 or else Get_Character
(C
) = '\'
9837 or else Get_Character
(C
) = ' '
9838 or else Get_Character
(C
) = '/'
9841 ("??interface name contains illegal character",
9842 Sloc
(SN
) + Source_Ptr
(J
));
9845 end Check_Form_Of_Interface_Name
;
9847 -- Start of processing for Process_Interface_Name
9850 -- If we are looking at a pragma that comes from an aspect then it
9851 -- needs to have its corresponding aspect argument expressions
9852 -- analyzed in addition to the generated pragma so that aspects
9853 -- within generic units get properly resolved.
9855 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9857 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9865 -- Obtain all interfacing aspects used to construct the pragma
9867 Get_Interfacing_Aspects
9868 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9870 -- Analyze the expression of aspect External_Name
9872 if Present
(EN
) then
9873 Analyze
(Expression
(EN
));
9876 -- Analyze the expressio of aspect Link_Name
9878 if Present
(LN
) then
9879 Analyze
(Expression
(LN
));
9884 if No
(Link_Arg
) then
9885 if No
(Ext_Arg
) then
9888 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9890 Link_Nam
:= Expression
(Ext_Arg
);
9893 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9894 Ext_Nam
:= Expression
(Ext_Arg
);
9899 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9900 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9901 Ext_Nam
:= Expression
(Ext_Arg
);
9902 Link_Nam
:= Expression
(Link_Arg
);
9905 -- Check expressions for external name and link name are static
9907 if Present
(Ext_Nam
) then
9908 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9909 Check_Form_Of_Interface_Name
(Ext_Nam
);
9911 -- Verify that external name is not the name of a local entity,
9912 -- which would hide the imported one and could lead to run-time
9913 -- surprises. The problem can only arise for entities declared in
9914 -- a package body (otherwise the external name is fully qualified
9915 -- and will not conflict).
9923 if Prag_Id
= Pragma_Import
then
9924 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9925 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9927 if Nam
/= Chars
(Subprogram_Def
)
9928 and then Present
(E
)
9929 and then not Is_Overloadable
(E
)
9930 and then Is_Immediately_Visible
(E
)
9931 and then not Is_Imported
(E
)
9932 and then Ekind
(Scope
(E
)) = E_Package
9935 while Present
(Par
) loop
9936 if Nkind
(Par
) = N_Package_Body
then
9937 Error_Msg_Sloc
:= Sloc
(E
);
9939 ("imported entity is hidden by & declared#",
9944 Par
:= Parent
(Par
);
9951 if Present
(Link_Nam
) then
9952 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9953 Check_Form_Of_Interface_Name
(Link_Nam
);
9956 -- If there is no link name, just set the external name
9958 if No
(Link_Nam
) then
9959 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9961 -- For the Link_Name case, the given literal is preceded by an
9962 -- asterisk, which indicates to GCC that the given name should be
9963 -- taken literally, and in particular that no prepending of
9964 -- underlines should occur, even in systems where this is the
9969 Store_String_Char
(Get_Char_Code
('*'));
9970 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9971 Store_String_Chars
(String_Val
);
9973 Make_String_Literal
(Sloc
(Link_Nam
),
9974 Strval
=> End_String
);
9977 -- Set the interface name. If the entity is a generic instance, use
9978 -- its alias, which is the callable entity.
9980 if Is_Generic_Instance
(Subprogram_Def
) then
9981 Set_Encoded_Interface_Name
9982 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9984 Set_Encoded_Interface_Name
9985 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9988 Check_Duplicated_Export_Name
(Link_Nam
);
9989 end Process_Interface_Name
;
9991 -----------------------------------------
9992 -- Process_Interrupt_Or_Attach_Handler --
9993 -----------------------------------------
9995 procedure Process_Interrupt_Or_Attach_Handler
is
9996 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9997 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10000 -- A pragma that applies to a Ghost entity becomes Ghost for the
10001 -- purposes of legality checks and removal of ignored Ghost code.
10003 Mark_Ghost_Pragma
(N
, Handler
);
10004 Set_Is_Interrupt_Handler
(Handler
);
10006 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10008 Record_Rep_Item
(Prot_Typ
, N
);
10010 -- Chain the pragma on the contract for completeness
10012 Add_Contract_Item
(N
, Handler
);
10013 end Process_Interrupt_Or_Attach_Handler
;
10015 --------------------------------------------------
10016 -- Process_Restrictions_Or_Restriction_Warnings --
10017 --------------------------------------------------
10019 -- Note: some of the simple identifier cases were handled in par-prag,
10020 -- but it is harmless (and more straightforward) to simply handle all
10021 -- cases here, even if it means we repeat a bit of work in some cases.
10023 procedure Process_Restrictions_Or_Restriction_Warnings
10027 R_Id
: Restriction_Id
;
10033 -- Ignore all Restrictions pragmas in CodePeer mode
10035 if CodePeer_Mode
then
10039 Check_Ada_83_Warning
;
10040 Check_At_Least_N_Arguments
(1);
10041 Check_Valid_Configuration_Pragma
;
10044 while Present
(Arg
) loop
10046 Expr
:= Get_Pragma_Arg
(Arg
);
10048 -- Case of no restriction identifier present
10050 if Id
= No_Name
then
10051 if Nkind
(Expr
) /= N_Identifier
then
10053 ("invalid form for restriction", Arg
);
10058 (Process_Restriction_Synonyms
(Expr
));
10060 if R_Id
not in All_Boolean_Restrictions
then
10061 Error_Msg_Name_1
:= Pname
;
10063 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10065 -- Check for possible misspelling
10067 for J
in Restriction_Id
loop
10069 Rnm
: constant String := Restriction_Id
'Image (J
);
10072 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10073 Name_Len
:= Rnm
'Length;
10074 Set_Casing
(All_Lower_Case
);
10076 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10079 (Source_Index
(Current_Sem_Unit
)));
10080 Error_Msg_String
(1 .. Rnm
'Length) :=
10081 Name_Buffer
(1 .. Name_Len
);
10082 Error_Msg_Strlen
:= Rnm
'Length;
10083 Error_Msg_N
-- CODEFIX
10084 ("\possible misspelling of ""~""",
10085 Get_Pragma_Arg
(Arg
));
10094 if Implementation_Restriction
(R_Id
) then
10095 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10098 -- Special processing for No_Elaboration_Code restriction
10100 if R_Id
= No_Elaboration_Code
then
10102 -- Restriction is only recognized within a configuration
10103 -- pragma file, or within a unit of the main extended
10104 -- program. Note: the test for Main_Unit is needed to
10105 -- properly include the case of configuration pragma files.
10107 if not (Current_Sem_Unit
= Main_Unit
10108 or else In_Extended_Main_Source_Unit
(N
))
10112 -- Don't allow in a subunit unless already specified in
10115 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10116 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10117 and then not Restriction_Active
(No_Elaboration_Code
)
10120 ("invalid specification of ""No_Elaboration_Code""",
10123 ("\restriction cannot be specified in a subunit", N
);
10125 ("\unless also specified in body or spec", N
);
10128 -- If we accept a No_Elaboration_Code restriction, then it
10129 -- needs to be added to the configuration restriction set so
10130 -- that we get proper application to other units in the main
10131 -- extended source as required.
10134 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10138 -- If this is a warning, then set the warning unless we already
10139 -- have a real restriction active (we never want a warning to
10140 -- override a real restriction).
10143 if not Restriction_Active
(R_Id
) then
10144 Set_Restriction
(R_Id
, N
);
10145 Restriction_Warnings
(R_Id
) := True;
10148 -- If real restriction case, then set it and make sure that the
10149 -- restriction warning flag is off, since a real restriction
10150 -- always overrides a warning.
10153 Set_Restriction
(R_Id
, N
);
10154 Restriction_Warnings
(R_Id
) := False;
10157 -- Check for obsolescent restrictions in Ada 2005 mode
10160 and then Ada_Version
>= Ada_2005
10161 and then (R_Id
= No_Asynchronous_Control
10163 R_Id
= No_Unchecked_Deallocation
10165 R_Id
= No_Unchecked_Conversion
)
10167 Check_Restriction
(No_Obsolescent_Features
, N
);
10170 -- A very special case that must be processed here: pragma
10171 -- Restrictions (No_Exceptions) turns off all run-time
10172 -- checking. This is a bit dubious in terms of the formal
10173 -- language definition, but it is what is intended by RM
10174 -- H.4(12). Restriction_Warnings never affects generated code
10175 -- so this is done only in the real restriction case.
10177 -- Atomic_Synchronization is not a real check, so it is not
10178 -- affected by this processing).
10180 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10181 -- run-time checks in CodePeer and GNATprove modes: we want to
10182 -- generate checks for analysis purposes, as set respectively
10183 -- by -gnatC and -gnatd.F
10186 and then not (CodePeer_Mode
or GNATprove_Mode
)
10187 and then R_Id
= No_Exceptions
10189 for J
in Scope_Suppress
.Suppress
'Range loop
10190 if J
/= Atomic_Synchronization
then
10191 Scope_Suppress
.Suppress
(J
) := True;
10196 -- Case of No_Dependence => unit-name. Note that the parser
10197 -- already made the necessary entry in the No_Dependence table.
10199 elsif Id
= Name_No_Dependence
then
10200 if not OK_No_Dependence_Unit_Name
(Expr
) then
10204 -- Case of No_Specification_Of_Aspect => aspect-identifier
10206 elsif Id
= Name_No_Specification_Of_Aspect
then
10211 if Nkind
(Expr
) /= N_Identifier
then
10214 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10217 if A_Id
= No_Aspect
then
10218 Error_Pragma_Arg
("invalid restriction name", Arg
);
10220 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10224 -- Case of No_Use_Of_Attribute => attribute-identifier
10226 elsif Id
= Name_No_Use_Of_Attribute
then
10227 if Nkind
(Expr
) /= N_Identifier
10228 or else not Is_Attribute_Name
(Chars
(Expr
))
10230 Error_Msg_N
("unknown attribute name??", Expr
);
10233 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10236 -- Case of No_Use_Of_Entity => fully-qualified-name
10238 elsif Id
= Name_No_Use_Of_Entity
then
10240 -- Restriction is only recognized within a configuration
10241 -- pragma file, or within a unit of the main extended
10242 -- program. Note: the test for Main_Unit is needed to
10243 -- properly include the case of configuration pragma files.
10245 if Current_Sem_Unit
= Main_Unit
10246 or else In_Extended_Main_Source_Unit
(N
)
10248 if not OK_No_Dependence_Unit_Name
(Expr
) then
10249 Error_Msg_N
("wrong form for entity name", Expr
);
10251 Set_Restriction_No_Use_Of_Entity
10252 (Expr
, Warn
, No_Profile
);
10256 -- Case of No_Use_Of_Pragma => pragma-identifier
10258 elsif Id
= Name_No_Use_Of_Pragma
then
10259 if Nkind
(Expr
) /= N_Identifier
10260 or else not Is_Pragma_Name
(Chars
(Expr
))
10262 Error_Msg_N
("unknown pragma name??", Expr
);
10264 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10267 -- All other cases of restriction identifier present
10270 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10271 Analyze_And_Resolve
(Expr
, Any_Integer
);
10273 if R_Id
not in All_Parameter_Restrictions
then
10275 ("invalid restriction parameter identifier", Arg
);
10277 elsif not Is_OK_Static_Expression
(Expr
) then
10278 Flag_Non_Static_Expr
10279 ("value must be static expression!", Expr
);
10282 elsif not Is_Integer_Type
(Etype
(Expr
))
10283 or else Expr_Value
(Expr
) < 0
10286 ("value must be non-negative integer", Arg
);
10289 -- Restriction pragma is active
10291 Val
:= Expr_Value
(Expr
);
10293 if not UI_Is_In_Int_Range
(Val
) then
10295 ("pragma ignored, value too large??", Arg
);
10298 -- Warning case. If the real restriction is active, then we
10299 -- ignore the request, since warning never overrides a real
10300 -- restriction. Otherwise we set the proper warning. Note that
10301 -- this circuit sets the warning again if it is already set,
10302 -- which is what we want, since the constant may have changed.
10305 if not Restriction_Active
(R_Id
) then
10307 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10308 Restriction_Warnings
(R_Id
) := True;
10311 -- Real restriction case, set restriction and make sure warning
10312 -- flag is off since real restriction always overrides warning.
10315 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10316 Restriction_Warnings
(R_Id
) := False;
10322 end Process_Restrictions_Or_Restriction_Warnings
;
10324 ---------------------------------
10325 -- Process_Suppress_Unsuppress --
10326 ---------------------------------
10328 -- Note: this procedure makes entries in the check suppress data
10329 -- structures managed by Sem. See spec of package Sem for full
10330 -- details on how we handle recording of check suppression.
10332 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10337 In_Package_Spec
: constant Boolean :=
10338 Is_Package_Or_Generic_Package
(Current_Scope
)
10339 and then not In_Package_Body
(Current_Scope
);
10341 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10342 -- Used to suppress a single check on the given entity
10344 --------------------------------
10345 -- Suppress_Unsuppress_Echeck --
10346 --------------------------------
10348 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10350 -- Check for error of trying to set atomic synchronization for
10351 -- a non-atomic variable.
10353 if C
= Atomic_Synchronization
10354 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10357 ("pragma & requires atomic type or variable",
10358 Pragma_Identifier
(Original_Node
(N
)));
10361 Set_Checks_May_Be_Suppressed
(E
);
10363 if In_Package_Spec
then
10364 Push_Global_Suppress_Stack_Entry
10367 Suppress
=> Suppress_Case
);
10369 Push_Local_Suppress_Stack_Entry
10372 Suppress
=> Suppress_Case
);
10375 -- If this is a first subtype, and the base type is distinct,
10376 -- then also set the suppress flags on the base type.
10378 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10379 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10381 end Suppress_Unsuppress_Echeck
;
10383 -- Start of processing for Process_Suppress_Unsuppress
10386 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10387 -- on user code: we want to generate checks for analysis purposes, as
10388 -- set respectively by -gnatC and -gnatd.F
10390 if Comes_From_Source
(N
)
10391 and then (CodePeer_Mode
or GNATprove_Mode
)
10396 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10397 -- declarative part or a package spec (RM 11.5(5)).
10399 if not Is_Configuration_Pragma
then
10400 Check_Is_In_Decl_Part_Or_Package_Spec
;
10403 Check_At_Least_N_Arguments
(1);
10404 Check_At_Most_N_Arguments
(2);
10405 Check_No_Identifier
(Arg1
);
10406 Check_Arg_Is_Identifier
(Arg1
);
10408 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10410 if C
= No_Check_Id
then
10412 ("argument of pragma% is not valid check name", Arg1
);
10415 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10417 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10419 ("Suppress of Elaboration_Check ignored in SPARK??",
10420 "\elaboration checking rules are statically enforced "
10421 & "(SPARK RM 7.7)", Arg1
);
10424 -- One-argument case
10426 if Arg_Count
= 1 then
10428 -- Make an entry in the local scope suppress table. This is the
10429 -- table that directly shows the current value of the scope
10430 -- suppress check for any check id value.
10432 if C
= All_Checks
then
10434 -- For All_Checks, we set all specific predefined checks with
10435 -- the exception of Elaboration_Check, which is handled
10436 -- specially because of not wanting All_Checks to have the
10437 -- effect of deactivating static elaboration order processing.
10438 -- Atomic_Synchronization is also not affected, since this is
10439 -- not a real check.
10441 for J
in Scope_Suppress
.Suppress
'Range loop
10442 if J
/= Elaboration_Check
10444 J
/= Atomic_Synchronization
10446 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10450 -- If not All_Checks, and predefined check, then set appropriate
10451 -- scope entry. Note that we will set Elaboration_Check if this
10452 -- is explicitly specified. Atomic_Synchronization is allowed
10453 -- only if internally generated and entity is atomic.
10455 elsif C
in Predefined_Check_Id
10456 and then (not Comes_From_Source
(N
)
10457 or else C
/= Atomic_Synchronization
)
10459 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10462 -- Also make an entry in the Local_Entity_Suppress table
10464 Push_Local_Suppress_Stack_Entry
10467 Suppress
=> Suppress_Case
);
10469 -- Case of two arguments present, where the check is suppressed for
10470 -- a specified entity (given as the second argument of the pragma)
10473 -- This is obsolescent in Ada 2005 mode
10475 if Ada_Version
>= Ada_2005
then
10476 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10479 Check_Optional_Identifier
(Arg2
, Name_On
);
10480 E_Id
:= Get_Pragma_Arg
(Arg2
);
10483 if not Is_Entity_Name
(E_Id
) then
10485 ("second argument of pragma% must be entity name", Arg2
);
10488 E
:= Entity
(E_Id
);
10494 -- A pragma that applies to a Ghost entity becomes Ghost for the
10495 -- purposes of legality checks and removal of ignored Ghost code.
10497 Mark_Ghost_Pragma
(N
, E
);
10499 -- Enforce RM 11.5(7) which requires that for a pragma that
10500 -- appears within a package spec, the named entity must be
10501 -- within the package spec. We allow the package name itself
10502 -- to be mentioned since that makes sense, although it is not
10503 -- strictly allowed by 11.5(7).
10506 and then E
/= Current_Scope
10507 and then Scope
(E
) /= Current_Scope
10510 ("entity in pragma% is not in package spec (RM 11.5(7))",
10514 -- Loop through homonyms. As noted below, in the case of a package
10515 -- spec, only homonyms within the package spec are considered.
10518 Suppress_Unsuppress_Echeck
(E
, C
);
10520 if Is_Generic_Instance
(E
)
10521 and then Is_Subprogram
(E
)
10522 and then Present
(Alias
(E
))
10524 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10527 -- Move to next homonym if not aspect spec case
10529 exit when From_Aspect_Specification
(N
);
10533 -- If we are within a package specification, the pragma only
10534 -- applies to homonyms in the same scope.
10536 exit when In_Package_Spec
10537 and then Scope
(E
) /= Current_Scope
;
10540 end Process_Suppress_Unsuppress
;
10542 -------------------------------
10543 -- Record_Independence_Check --
10544 -------------------------------
10546 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10547 pragma Unreferenced
(N
, E
);
10549 -- For GCC back ends the validation is done a priori
10550 -- ??? This code is dead, might be useful in the future
10552 -- if not AAMP_On_Target then
10556 -- Independence_Checks.Append ((N, E));
10559 end Record_Independence_Check
;
10565 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10567 if Is_Imported
(E
) then
10569 ("cannot export entity& that was previously imported", Arg
);
10571 elsif Present
(Address_Clause
(E
))
10572 and then not Relaxed_RM_Semantics
10575 ("cannot export entity& that has an address clause", Arg
);
10578 Set_Is_Exported
(E
);
10580 -- Generate a reference for entity explicitly, because the
10581 -- identifier may be overloaded and name resolution will not
10584 Generate_Reference
(E
, Arg
);
10586 -- Deal with exporting non-library level entity
10588 if not Is_Library_Level_Entity
(E
) then
10590 -- Not allowed at all for subprograms
10592 if Is_Subprogram
(E
) then
10593 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10595 -- Otherwise set public and statically allocated
10599 Set_Is_Statically_Allocated
(E
);
10601 -- Warn if the corresponding W flag is set
10603 if Warn_On_Export_Import
10605 -- Only do this for something that was in the source. Not
10606 -- clear if this can be False now (there used for sure to be
10607 -- cases on some systems where it was False), but anyway the
10608 -- test is harmless if not needed, so it is retained.
10610 and then Comes_From_Source
(Arg
)
10613 ("?x?& has been made static as a result of Export",
10616 ("\?x?this usage is non-standard and non-portable",
10622 if Warn_On_Export_Import
and then Is_Type
(E
) then
10623 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10626 if Warn_On_Export_Import
and Inside_A_Generic
then
10628 ("all instances of& will have the same external name?x?",
10633 ----------------------------------------------
10634 -- Set_Extended_Import_Export_External_Name --
10635 ----------------------------------------------
10637 procedure Set_Extended_Import_Export_External_Name
10638 (Internal_Ent
: Entity_Id
;
10639 Arg_External
: Node_Id
)
10641 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10642 New_Name
: Node_Id
;
10645 if No
(Arg_External
) then
10649 Check_Arg_Is_External_Name
(Arg_External
);
10651 if Nkind
(Arg_External
) = N_String_Literal
then
10652 if String_Length
(Strval
(Arg_External
)) = 0 then
10655 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10658 elsif Nkind
(Arg_External
) = N_Identifier
then
10659 New_Name
:= Get_Default_External_Name
(Arg_External
);
10661 -- Check_Arg_Is_External_Name should let through only identifiers and
10662 -- string literals or static string expressions (which are folded to
10663 -- string literals).
10666 raise Program_Error
;
10669 -- If we already have an external name set (by a prior normal Import
10670 -- or Export pragma), then the external names must match
10672 if Present
(Interface_Name
(Internal_Ent
)) then
10674 -- Ignore mismatching names in CodePeer mode, to support some
10675 -- old compilers which would export the same procedure under
10676 -- different names, e.g:
10678 -- pragma Export_Procedure (P, "a");
10679 -- pragma Export_Procedure (P, "b");
10681 if CodePeer_Mode
then
10685 Check_Matching_Internal_Names
: declare
10686 S1
: constant String_Id
:= Strval
(Old_Name
);
10687 S2
: constant String_Id
:= Strval
(New_Name
);
10689 procedure Mismatch
;
10690 pragma No_Return
(Mismatch
);
10691 -- Called if names do not match
10697 procedure Mismatch
is
10699 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10701 ("external name does not match that given #",
10705 -- Start of processing for Check_Matching_Internal_Names
10708 if String_Length
(S1
) /= String_Length
(S2
) then
10712 for J
in 1 .. String_Length
(S1
) loop
10713 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10718 end Check_Matching_Internal_Names
;
10720 -- Otherwise set the given name
10723 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10724 Check_Duplicated_Export_Name
(New_Name
);
10726 end Set_Extended_Import_Export_External_Name
;
10732 procedure Set_Imported
(E
: Entity_Id
) is
10734 -- Error message if already imported or exported
10736 if Is_Exported
(E
) or else Is_Imported
(E
) then
10738 -- Error if being set Exported twice
10740 if Is_Exported
(E
) then
10741 Error_Msg_NE
("entity& was previously exported", N
, E
);
10743 -- Ignore error in CodePeer mode where we treat all imported
10744 -- subprograms as unknown.
10746 elsif CodePeer_Mode
then
10749 -- OK if Import/Interface case
10751 elsif Import_Interface_Present
(N
) then
10754 -- Error if being set Imported twice
10757 Error_Msg_NE
("entity& was previously imported", N
, E
);
10760 Error_Msg_Name_1
:= Pname
;
10762 ("\(pragma% applies to all previous entities)", N
);
10764 Error_Msg_Sloc
:= Sloc
(E
);
10765 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10767 -- Here if not previously imported or exported, OK to import
10770 Set_Is_Imported
(E
);
10772 -- For subprogram, set Import_Pragma field
10774 if Is_Subprogram
(E
) then
10775 Set_Import_Pragma
(E
, N
);
10778 -- If the entity is an object that is not at the library level,
10779 -- then it is statically allocated. We do not worry about objects
10780 -- with address clauses in this context since they are not really
10781 -- imported in the linker sense.
10784 and then not Is_Library_Level_Entity
(E
)
10785 and then No
(Address_Clause
(E
))
10787 Set_Is_Statically_Allocated
(E
);
10794 -------------------------
10795 -- Set_Mechanism_Value --
10796 -------------------------
10798 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10799 -- analyzed, since it is semantic nonsense), so we get it in the exact
10800 -- form created by the parser.
10802 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10803 procedure Bad_Mechanism
;
10804 pragma No_Return
(Bad_Mechanism
);
10805 -- Signal bad mechanism name
10807 -------------------
10808 -- Bad_Mechanism --
10809 -------------------
10811 procedure Bad_Mechanism
is
10813 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10816 -- Start of processing for Set_Mechanism_Value
10819 if Mechanism
(Ent
) /= Default_Mechanism
then
10821 ("mechanism for & has already been set", Mech_Name
, Ent
);
10824 -- MECHANISM_NAME ::= value | reference
10826 if Nkind
(Mech_Name
) = N_Identifier
then
10827 if Chars
(Mech_Name
) = Name_Value
then
10828 Set_Mechanism
(Ent
, By_Copy
);
10831 elsif Chars
(Mech_Name
) = Name_Reference
then
10832 Set_Mechanism
(Ent
, By_Reference
);
10835 elsif Chars
(Mech_Name
) = Name_Copy
then
10837 ("bad mechanism name, Value assumed", Mech_Name
);
10846 end Set_Mechanism_Value
;
10848 --------------------------
10849 -- Set_Rational_Profile --
10850 --------------------------
10852 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10853 -- extension to the semantics of renaming declarations.
10855 procedure Set_Rational_Profile
is
10857 Implicit_Packing
:= True;
10858 Overriding_Renamings
:= True;
10859 Use_VADS_Size
:= True;
10860 end Set_Rational_Profile
;
10862 ---------------------------
10863 -- Set_Ravenscar_Profile --
10864 ---------------------------
10866 -- The tasks to be done here are
10868 -- Set required policies
10870 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10871 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10872 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10873 -- (For GNAT_Ravenscar_EDF profile)
10874 -- pragma Locking_Policy (Ceiling_Locking)
10876 -- Set Detect_Blocking mode
10878 -- Set required restrictions (see System.Rident for detailed list)
10880 -- Set the No_Dependence rules
10881 -- No_Dependence => Ada.Asynchronous_Task_Control
10882 -- No_Dependence => Ada.Calendar
10883 -- No_Dependence => Ada.Execution_Time.Group_Budget
10884 -- No_Dependence => Ada.Execution_Time.Timers
10885 -- No_Dependence => Ada.Task_Attributes
10886 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10888 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10889 procedure Set_Error_Msg_To_Profile_Name
;
10890 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10893 -----------------------------------
10894 -- Set_Error_Msg_To_Profile_Name --
10895 -----------------------------------
10897 procedure Set_Error_Msg_To_Profile_Name
is
10898 Prof_Nam
: constant Node_Id
:=
10900 (First
(Pragma_Argument_Associations
(N
)));
10903 Get_Name_String
(Chars
(Prof_Nam
));
10904 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10905 Error_Msg_Strlen
:= Name_Len
;
10906 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10907 end Set_Error_Msg_To_Profile_Name
;
10916 Profile_Dispatching_Policy
: Character;
10918 -- Start of processing for Set_Ravenscar_Profile
10921 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10923 if Profile
= GNAT_Ravenscar_EDF
then
10924 Profile_Dispatching_Policy
:= 'E';
10926 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10929 Profile_Dispatching_Policy
:= 'F';
10932 if Task_Dispatching_Policy
/= ' '
10933 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10935 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10936 Set_Error_Msg_To_Profile_Name
;
10937 Error_Pragma
("Profile (~) incompatible with policy#");
10939 -- Set the FIFO_Within_Priorities policy, but always preserve
10940 -- System_Location since we like the error message with the run time
10944 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10946 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10947 Task_Dispatching_Policy_Sloc
:= Loc
;
10951 -- pragma Locking_Policy (Ceiling_Locking)
10953 if Locking_Policy
/= ' '
10954 and then Locking_Policy
/= 'C'
10956 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10957 Set_Error_Msg_To_Profile_Name
;
10958 Error_Pragma
("Profile (~) incompatible with policy#");
10960 -- Set the Ceiling_Locking policy, but preserve System_Location since
10961 -- we like the error message with the run time name.
10964 Locking_Policy
:= 'C';
10966 if Locking_Policy_Sloc
/= System_Location
then
10967 Locking_Policy_Sloc
:= Loc
;
10971 -- pragma Detect_Blocking
10973 Detect_Blocking
:= True;
10975 -- Set the corresponding restrictions
10977 Set_Profile_Restrictions
10978 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10980 -- Set the No_Dependence restrictions
10982 -- The following No_Dependence restrictions:
10983 -- No_Dependence => Ada.Asynchronous_Task_Control
10984 -- No_Dependence => Ada.Calendar
10985 -- No_Dependence => Ada.Task_Attributes
10986 -- are already set by previous call to Set_Profile_Restrictions.
10988 -- Set the following restrictions which were added to Ada 2005:
10989 -- No_Dependence => Ada.Execution_Time.Group_Budget
10990 -- No_Dependence => Ada.Execution_Time.Timers
10992 if Ada_Version
>= Ada_2005
then
10993 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
10994 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
10997 Make_Selected_Component
11000 Selector_Name
=> Sel_Id
);
11002 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
11005 Make_Selected_Component
11008 Selector_Name
=> Sel_Id
);
11010 Set_Restriction_No_Dependence
11012 Warn
=> Treat_Restrictions_As_Warnings
,
11013 Profile
=> Ravenscar
);
11015 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
11018 Make_Selected_Component
11021 Selector_Name
=> Sel_Id
);
11023 Set_Restriction_No_Dependence
11025 Warn
=> Treat_Restrictions_As_Warnings
,
11026 Profile
=> Ravenscar
);
11029 -- Set the following restriction which was added to Ada 2012 (see
11031 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11033 if Ada_Version
>= Ada_2012
then
11034 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
11035 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
11038 Make_Selected_Component
11041 Selector_Name
=> Sel_Id
);
11043 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
11046 Make_Selected_Component
11049 Selector_Name
=> Sel_Id
);
11051 Set_Restriction_No_Dependence
11053 Warn
=> Treat_Restrictions_As_Warnings
,
11054 Profile
=> Ravenscar
);
11056 end Set_Ravenscar_Profile
;
11058 -- Start of processing for Analyze_Pragma
11061 -- The following code is a defense against recursion. Not clear that
11062 -- this can happen legitimately, but perhaps some error situations can
11063 -- cause it, and we did see this recursion during testing.
11065 if Analyzed
(N
) then
11071 Check_Restriction_No_Use_Of_Pragma
(N
);
11073 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11074 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11076 if Should_Ignore_Pragma_Sem
(N
)
11077 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11078 and then Ignore_Rep_Clauses
)
11083 -- Deal with unrecognized pragma
11085 if not Is_Pragma_Name
(Pname
) then
11086 if Warn_On_Unrecognized_Pragma
then
11087 Error_Msg_Name_1
:= Pname
;
11088 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11090 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11091 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11092 Error_Msg_Name_1
:= PN
;
11093 Error_Msg_N
-- CODEFIX
11094 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11103 -- Here to start processing for recognized pragma
11105 Pname
:= Original_Aspect_Pragma_Name
(N
);
11107 -- Capture setting of Opt.Uneval_Old
11109 case Opt
.Uneval_Old
is
11111 Set_Uneval_Old_Accept
(N
);
11117 Set_Uneval_Old_Warn
(N
);
11120 raise Program_Error
;
11123 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11124 -- is already set, indicating that we have already checked the policy
11125 -- at the right point. This happens for example in the case of a pragma
11126 -- that is derived from an Aspect.
11128 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11131 -- For a pragma that is a rewriting of another pragma, copy the
11132 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11134 elsif Is_Rewrite_Substitution
(N
)
11135 and then Nkind
(Original_Node
(N
)) = N_Pragma
11136 and then Original_Node
(N
) /= N
11138 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11139 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11141 -- Otherwise query the applicable policy at this point
11144 Check_Applicable_Policy
(N
);
11146 -- If pragma is disabled, rewrite as NULL and skip analysis
11148 if Is_Disabled
(N
) then
11149 Rewrite
(N
, Make_Null_Statement
(Loc
));
11155 -- Preset arguments
11163 if Present
(Pragma_Argument_Associations
(N
)) then
11164 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11165 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11167 if Present
(Arg1
) then
11168 Arg2
:= Next
(Arg1
);
11170 if Present
(Arg2
) then
11171 Arg3
:= Next
(Arg2
);
11173 if Present
(Arg3
) then
11174 Arg4
:= Next
(Arg3
);
11180 -- An enumeration type defines the pragmas that are supported by the
11181 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11182 -- into the corresponding enumeration value for the following case.
11190 -- pragma Abort_Defer;
11192 when Pragma_Abort_Defer
=>
11194 Check_Arg_Count
(0);
11196 -- The only required semantic processing is to check the
11197 -- placement. This pragma must appear at the start of the
11198 -- statement sequence of a handled sequence of statements.
11200 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11201 or else N
/= First
(Statements
(Parent
(N
)))
11206 --------------------
11207 -- Abstract_State --
11208 --------------------
11210 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11212 -- ABSTRACT_STATE_LIST ::=
11214 -- | STATE_NAME_WITH_OPTIONS
11215 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11217 -- STATE_NAME_WITH_OPTIONS ::=
11219 -- | (STATE_NAME with OPTION_LIST)
11221 -- OPTION_LIST ::= OPTION {, OPTION}
11225 -- | NAME_VALUE_OPTION
11227 -- SIMPLE_OPTION ::= Ghost | Synchronous
11229 -- NAME_VALUE_OPTION ::=
11230 -- Part_Of => ABSTRACT_STATE
11231 -- | External [=> EXTERNAL_PROPERTY_LIST]
11233 -- EXTERNAL_PROPERTY_LIST ::=
11234 -- EXTERNAL_PROPERTY
11235 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11237 -- EXTERNAL_PROPERTY ::=
11238 -- Async_Readers [=> boolean_EXPRESSION]
11239 -- | Async_Writers [=> boolean_EXPRESSION]
11240 -- | Effective_Reads [=> boolean_EXPRESSION]
11241 -- | Effective_Writes [=> boolean_EXPRESSION]
11242 -- others => boolean_EXPRESSION
11244 -- STATE_NAME ::= defining_identifier
11246 -- ABSTRACT_STATE ::= name
11248 -- Characteristics:
11250 -- * Analysis - The annotation is fully analyzed immediately upon
11251 -- elaboration as it cannot forward reference entities.
11253 -- * Expansion - None.
11255 -- * Template - The annotation utilizes the generic template of the
11256 -- related package declaration.
11258 -- * Globals - The annotation cannot reference global entities.
11260 -- * Instance - The annotation is instantiated automatically when
11261 -- the related generic package is instantiated.
11263 when Pragma_Abstract_State
=> Abstract_State
: declare
11264 Missing_Parentheses
: Boolean := False;
11265 -- Flag set when a state declaration with options is not properly
11268 -- Flags used to verify the consistency of states
11270 Non_Null_Seen
: Boolean := False;
11271 Null_Seen
: Boolean := False;
11273 procedure Analyze_Abstract_State
11275 Pack_Id
: Entity_Id
);
11276 -- Verify the legality of a single state declaration. Create and
11277 -- decorate a state abstraction entity and introduce it into the
11278 -- visibility chain. Pack_Id denotes the entity or the related
11279 -- package where pragma Abstract_State appears.
11281 procedure Malformed_State_Error
(State
: Node_Id
);
11282 -- Emit an error concerning the illegal declaration of abstract
11283 -- state State. This routine diagnoses syntax errors that lead to
11284 -- a different parse tree. The error is issued regardless of the
11285 -- SPARK mode in effect.
11287 ----------------------------
11288 -- Analyze_Abstract_State --
11289 ----------------------------
11291 procedure Analyze_Abstract_State
11293 Pack_Id
: Entity_Id
)
11295 -- Flags used to verify the consistency of options
11297 AR_Seen
: Boolean := False;
11298 AW_Seen
: Boolean := False;
11299 ER_Seen
: Boolean := False;
11300 EW_Seen
: Boolean := False;
11301 External_Seen
: Boolean := False;
11302 Ghost_Seen
: Boolean := False;
11303 Others_Seen
: Boolean := False;
11304 Part_Of_Seen
: Boolean := False;
11305 Synchronous_Seen
: Boolean := False;
11307 -- Flags used to store the static value of all external states'
11310 AR_Val
: Boolean := False;
11311 AW_Val
: Boolean := False;
11312 ER_Val
: Boolean := False;
11313 EW_Val
: Boolean := False;
11315 State_Id
: Entity_Id
:= Empty
;
11316 -- The entity to be generated for the current state declaration
11318 procedure Analyze_External_Option
(Opt
: Node_Id
);
11319 -- Verify the legality of option External
11321 procedure Analyze_External_Property
11323 Expr
: Node_Id
:= Empty
);
11324 -- Verify the legailty of a single external property. Prop
11325 -- denotes the external property. Expr is the expression used
11326 -- to set the property.
11328 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11329 -- Verify the legality of option Part_Of
11331 procedure Check_Duplicate_Option
11333 Status
: in out Boolean);
11334 -- Flag Status denotes whether a particular option has been
11335 -- seen while processing a state. This routine verifies that
11336 -- Opt is not a duplicate option and sets the flag Status
11337 -- (SPARK RM 7.1.4(1)).
11339 procedure Check_Duplicate_Property
11341 Status
: in out Boolean);
11342 -- Flag Status denotes whether a particular property has been
11343 -- seen while processing option External. This routine verifies
11344 -- that Prop is not a duplicate property and sets flag Status.
11345 -- Opt is not a duplicate property and sets the flag Status.
11346 -- (SPARK RM 7.1.4(2))
11348 procedure Check_Ghost_Synchronous
;
11349 -- Ensure that the abstract state is not subject to both Ghost
11350 -- and Synchronous simple options. Emit an error if this is the
11353 procedure Create_Abstract_State
11357 Is_Null
: Boolean);
11358 -- Generate an abstract state entity with name Nam and enter it
11359 -- into visibility. Decl is the "declaration" of the state as
11360 -- it appears in pragma Abstract_State. Loc is the location of
11361 -- the related state "declaration". Flag Is_Null should be set
11362 -- when the associated Abstract_State pragma defines a null
11365 -----------------------------
11366 -- Analyze_External_Option --
11367 -----------------------------
11369 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11370 Errors
: constant Nat
:= Serious_Errors_Detected
;
11372 Props
: Node_Id
:= Empty
;
11375 if Nkind
(Opt
) = N_Component_Association
then
11376 Props
:= Expression
(Opt
);
11379 -- External state with properties
11381 if Present
(Props
) then
11383 -- Multiple properties appear as an aggregate
11385 if Nkind
(Props
) = N_Aggregate
then
11387 -- Simple property form
11389 Prop
:= First
(Expressions
(Props
));
11390 while Present
(Prop
) loop
11391 Analyze_External_Property
(Prop
);
11395 -- Property with expression form
11397 Prop
:= First
(Component_Associations
(Props
));
11398 while Present
(Prop
) loop
11399 Analyze_External_Property
11400 (Prop
=> First
(Choices
(Prop
)),
11401 Expr
=> Expression
(Prop
));
11409 Analyze_External_Property
(Props
);
11412 -- An external state defined without any properties defaults
11413 -- all properties to True.
11422 -- Once all external properties have been processed, verify
11423 -- their mutual interaction. Do not perform the check when
11424 -- at least one of the properties is illegal as this will
11425 -- produce a bogus error.
11427 if Errors
= Serious_Errors_Detected
then
11428 Check_External_Properties
11429 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11431 end Analyze_External_Option
;
11433 -------------------------------
11434 -- Analyze_External_Property --
11435 -------------------------------
11437 procedure Analyze_External_Property
11439 Expr
: Node_Id
:= Empty
)
11441 Expr_Val
: Boolean;
11444 -- Check the placement of "others" (if available)
11446 if Nkind
(Prop
) = N_Others_Choice
then
11447 if Others_Seen
then
11449 ("only one others choice allowed in option External",
11452 Others_Seen
:= True;
11455 elsif Others_Seen
then
11457 ("others must be the last property in option External",
11460 -- The only remaining legal options are the four predefined
11461 -- external properties.
11463 elsif Nkind
(Prop
) = N_Identifier
11464 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11465 Name_Async_Writers
,
11466 Name_Effective_Reads
,
11467 Name_Effective_Writes
)
11471 -- Otherwise the construct is not a valid property
11474 SPARK_Msg_N
("invalid external state property", Prop
);
11478 -- Ensure that the expression of the external state property
11479 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11481 if Present
(Expr
) then
11482 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11484 if Is_OK_Static_Expression
(Expr
) then
11485 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11488 ("expression of external state property must be "
11493 -- The lack of expression defaults the property to True
11499 -- Named properties
11501 if Nkind
(Prop
) = N_Identifier
then
11502 if Chars
(Prop
) = Name_Async_Readers
then
11503 Check_Duplicate_Property
(Prop
, AR_Seen
);
11504 AR_Val
:= Expr_Val
;
11506 elsif Chars
(Prop
) = Name_Async_Writers
then
11507 Check_Duplicate_Property
(Prop
, AW_Seen
);
11508 AW_Val
:= Expr_Val
;
11510 elsif Chars
(Prop
) = Name_Effective_Reads
then
11511 Check_Duplicate_Property
(Prop
, ER_Seen
);
11512 ER_Val
:= Expr_Val
;
11515 Check_Duplicate_Property
(Prop
, EW_Seen
);
11516 EW_Val
:= Expr_Val
;
11519 -- The handling of property "others" must take into account
11520 -- all other named properties that have been encountered so
11521 -- far. Only those that have not been seen are affected by
11525 if not AR_Seen
then
11526 AR_Val
:= Expr_Val
;
11529 if not AW_Seen
then
11530 AW_Val
:= Expr_Val
;
11533 if not ER_Seen
then
11534 ER_Val
:= Expr_Val
;
11537 if not EW_Seen
then
11538 EW_Val
:= Expr_Val
;
11541 end Analyze_External_Property
;
11543 ----------------------------
11544 -- Analyze_Part_Of_Option --
11545 ----------------------------
11547 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11548 Encap
: constant Node_Id
:= Expression
(Opt
);
11549 Constits
: Elist_Id
;
11550 Encap_Id
: Entity_Id
;
11554 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11557 (Indic
=> First
(Choices
(Opt
)),
11558 Item_Id
=> State_Id
,
11560 Encap_Id
=> Encap_Id
,
11563 -- The Part_Of indicator transforms the abstract state into
11564 -- a constituent of the encapsulating state or single
11565 -- concurrent type.
11568 pragma Assert
(Present
(Encap_Id
));
11569 Constits
:= Part_Of_Constituents
(Encap_Id
);
11571 if No
(Constits
) then
11572 Constits
:= New_Elmt_List
;
11573 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11576 Append_Elmt
(State_Id
, Constits
);
11577 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11579 end Analyze_Part_Of_Option
;
11581 ----------------------------
11582 -- Check_Duplicate_Option --
11583 ----------------------------
11585 procedure Check_Duplicate_Option
11587 Status
: in out Boolean)
11591 SPARK_Msg_N
("duplicate state option", Opt
);
11595 end Check_Duplicate_Option
;
11597 ------------------------------
11598 -- Check_Duplicate_Property --
11599 ------------------------------
11601 procedure Check_Duplicate_Property
11603 Status
: in out Boolean)
11607 SPARK_Msg_N
("duplicate external property", Prop
);
11611 end Check_Duplicate_Property
;
11613 -----------------------------
11614 -- Check_Ghost_Synchronous --
11615 -----------------------------
11617 procedure Check_Ghost_Synchronous
is
11619 -- A synchronized abstract state cannot be Ghost and vice
11620 -- versa (SPARK RM 6.9(19)).
11622 if Ghost_Seen
and Synchronous_Seen
then
11623 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11625 end Check_Ghost_Synchronous
;
11627 ---------------------------
11628 -- Create_Abstract_State --
11629 ---------------------------
11631 procedure Create_Abstract_State
11638 -- The abstract state may be semi-declared when the related
11639 -- package was withed through a limited with clause. In that
11640 -- case reuse the entity to fully declare the state.
11642 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11643 State_Id
:= Entity
(Decl
);
11645 -- Otherwise the elaboration of pragma Abstract_State
11646 -- declares the state.
11649 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11651 if Present
(Decl
) then
11652 Set_Entity
(Decl
, State_Id
);
11656 -- Null states never come from source
11658 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11659 Set_Parent
(State_Id
, State
);
11660 Set_Ekind
(State_Id
, E_Abstract_State
);
11661 Set_Etype
(State_Id
, Standard_Void_Type
);
11662 Set_Encapsulating_State
(State_Id
, Empty
);
11664 -- Set the SPARK mode from the current context
11666 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
11667 Set_SPARK_Pragma_Inherited
(State_Id
);
11669 -- An abstract state declared within a Ghost region becomes
11670 -- Ghost (SPARK RM 6.9(2)).
11672 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11673 Set_Is_Ghost_Entity
(State_Id
);
11676 -- Establish a link between the state declaration and the
11677 -- abstract state entity. Note that a null state remains as
11678 -- N_Null and does not carry any linkages.
11680 if not Is_Null
then
11681 if Present
(Decl
) then
11682 Set_Entity
(Decl
, State_Id
);
11683 Set_Etype
(Decl
, Standard_Void_Type
);
11686 -- Every non-null state must be defined, nameable and
11689 Push_Scope
(Pack_Id
);
11690 Generate_Definition
(State_Id
);
11691 Enter_Name
(State_Id
);
11694 end Create_Abstract_State
;
11701 -- Start of processing for Analyze_Abstract_State
11704 -- A package with a null abstract state is not allowed to
11705 -- declare additional states.
11709 ("package & has null abstract state", State
, Pack_Id
);
11711 -- Null states appear as internally generated entities
11713 elsif Nkind
(State
) = N_Null
then
11714 Create_Abstract_State
11715 (Nam
=> New_Internal_Name
('S'),
11717 Loc
=> Sloc
(State
),
11721 -- Catch a case where a null state appears in a list of
11722 -- non-null states.
11724 if Non_Null_Seen
then
11726 ("package & has non-null abstract state",
11730 -- Simple state declaration
11732 elsif Nkind
(State
) = N_Identifier
then
11733 Create_Abstract_State
11734 (Nam
=> Chars
(State
),
11736 Loc
=> Sloc
(State
),
11738 Non_Null_Seen
:= True;
11740 -- State declaration with various options. This construct
11741 -- appears as an extension aggregate in the tree.
11743 elsif Nkind
(State
) = N_Extension_Aggregate
then
11744 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11745 Create_Abstract_State
11746 (Nam
=> Chars
(Ancestor_Part
(State
)),
11747 Decl
=> Ancestor_Part
(State
),
11748 Loc
=> Sloc
(Ancestor_Part
(State
)),
11750 Non_Null_Seen
:= True;
11753 ("state name must be an identifier",
11754 Ancestor_Part
(State
));
11757 -- Options External, Ghost and Synchronous appear as
11760 Opt
:= First
(Expressions
(State
));
11761 while Present
(Opt
) loop
11762 if Nkind
(Opt
) = N_Identifier
then
11766 if Chars
(Opt
) = Name_External
then
11767 Check_Duplicate_Option
(Opt
, External_Seen
);
11768 Analyze_External_Option
(Opt
);
11772 elsif Chars
(Opt
) = Name_Ghost
then
11773 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11774 Check_Ghost_Synchronous
;
11776 if Present
(State_Id
) then
11777 Set_Is_Ghost_Entity
(State_Id
);
11782 elsif Chars
(Opt
) = Name_Synchronous
then
11783 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11784 Check_Ghost_Synchronous
;
11786 -- Option Part_Of without an encapsulating state is
11787 -- illegal (SPARK RM 7.1.4(9)).
11789 elsif Chars
(Opt
) = Name_Part_Of
then
11791 ("indicator Part_Of must denote abstract state, "
11792 & "single protected type or single task type",
11795 -- Do not emit an error message when a previous state
11796 -- declaration with options was not parenthesized as
11797 -- the option is actually another state declaration.
11799 -- with Abstract_State
11800 -- (State_1 with ..., -- missing parentheses
11801 -- (State_2 with ...),
11802 -- State_3) -- ok state declaration
11804 elsif Missing_Parentheses
then
11807 -- Otherwise the option is not allowed. Note that it
11808 -- is not possible to distinguish between an option
11809 -- and a state declaration when a previous state with
11810 -- options not properly parentheses.
11812 -- with Abstract_State
11813 -- (State_1 with ..., -- missing parentheses
11814 -- State_2); -- could be an option
11818 ("simple option not allowed in state declaration",
11822 -- Catch a case where missing parentheses around a state
11823 -- declaration with options cause a subsequent state
11824 -- declaration with options to be treated as an option.
11826 -- with Abstract_State
11827 -- (State_1 with ..., -- missing parentheses
11828 -- (State_2 with ...))
11830 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11831 Missing_Parentheses
:= True;
11833 ("state declaration must be parenthesized",
11834 Ancestor_Part
(State
));
11836 -- Otherwise the option is malformed
11839 SPARK_Msg_N
("malformed option", Opt
);
11845 -- Options External and Part_Of appear as component
11848 Opt
:= First
(Component_Associations
(State
));
11849 while Present
(Opt
) loop
11850 Opt_Nam
:= First
(Choices
(Opt
));
11852 if Nkind
(Opt_Nam
) = N_Identifier
then
11853 if Chars
(Opt_Nam
) = Name_External
then
11854 Analyze_External_Option
(Opt
);
11856 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11857 Analyze_Part_Of_Option
(Opt
);
11860 SPARK_Msg_N
("invalid state option", Opt
);
11863 SPARK_Msg_N
("invalid state option", Opt
);
11869 -- Any other attempt to declare a state is illegal
11872 Malformed_State_Error
(State
);
11876 -- Guard against a junk state. In such cases no entity is
11877 -- generated and the subsequent checks cannot be applied.
11879 if Present
(State_Id
) then
11881 -- Verify whether the state does not introduce an illegal
11882 -- hidden state within a package subject to a null abstract
11885 Check_No_Hidden_State
(State_Id
);
11887 -- Check whether the lack of option Part_Of agrees with the
11888 -- placement of the abstract state with respect to the state
11891 if not Part_Of_Seen
then
11892 Check_Missing_Part_Of
(State_Id
);
11895 -- Associate the state with its related package
11897 if No
(Abstract_States
(Pack_Id
)) then
11898 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11901 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11903 end Analyze_Abstract_State
;
11905 ---------------------------
11906 -- Malformed_State_Error --
11907 ---------------------------
11909 procedure Malformed_State_Error
(State
: Node_Id
) is
11911 Error_Msg_N
("malformed abstract state declaration", State
);
11913 -- An abstract state with a simple option is being declared
11914 -- with "=>" rather than the legal "with". The state appears
11915 -- as a component association.
11917 if Nkind
(State
) = N_Component_Association
then
11918 Error_Msg_N
("\use WITH to specify simple option", State
);
11920 end Malformed_State_Error
;
11924 Pack_Decl
: Node_Id
;
11925 Pack_Id
: Entity_Id
;
11929 -- Start of processing for Abstract_State
11933 Check_No_Identifiers
;
11934 Check_Arg_Count
(1);
11936 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11938 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11939 N_Package_Declaration
)
11945 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11947 -- A pragma that applies to a Ghost entity becomes Ghost for the
11948 -- purposes of legality checks and removal of ignored Ghost code.
11950 Mark_Ghost_Pragma
(N
, Pack_Id
);
11951 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11953 -- Chain the pragma on the contract for completeness
11955 Add_Contract_Item
(N
, Pack_Id
);
11957 -- The legality checks of pragmas Abstract_State, Initializes, and
11958 -- Initial_Condition are affected by the SPARK mode in effect. In
11959 -- addition, these three pragmas are subject to an inherent order:
11961 -- 1) Abstract_State
11963 -- 3) Initial_Condition
11965 -- Analyze all these pragmas in the order outlined above
11967 Analyze_If_Present
(Pragma_SPARK_Mode
);
11968 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11970 -- Multiple non-null abstract states appear as an aggregate
11972 if Nkind
(States
) = N_Aggregate
then
11973 State
:= First
(Expressions
(States
));
11974 while Present
(State
) loop
11975 Analyze_Abstract_State
(State
, Pack_Id
);
11979 -- An abstract state with a simple option is being illegaly
11980 -- declared with "=>" rather than "with". In this case the
11981 -- state declaration appears as a component association.
11983 if Present
(Component_Associations
(States
)) then
11984 State
:= First
(Component_Associations
(States
));
11985 while Present
(State
) loop
11986 Malformed_State_Error
(State
);
11991 -- Various forms of a single abstract state. Note that these may
11992 -- include malformed state declarations.
11995 Analyze_Abstract_State
(States
, Pack_Id
);
11998 Analyze_If_Present
(Pragma_Initializes
);
11999 Analyze_If_Present
(Pragma_Initial_Condition
);
12000 end Abstract_State
;
12008 -- Note: this pragma also has some specific processing in Par.Prag
12009 -- because we want to set the Ada version mode during parsing.
12011 when Pragma_Ada_83
=>
12013 Check_Arg_Count
(0);
12015 -- We really should check unconditionally for proper configuration
12016 -- pragma placement, since we really don't want mixed Ada modes
12017 -- within a single unit, and the GNAT reference manual has always
12018 -- said this was a configuration pragma, but we did not check and
12019 -- are hesitant to add the check now.
12021 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12022 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12023 -- or Ada 2012 mode.
12025 if Ada_Version
>= Ada_2005
then
12026 Check_Valid_Configuration_Pragma
;
12029 -- Now set Ada 83 mode
12031 if Latest_Ada_Only
then
12032 Error_Pragma
("??pragma% ignored");
12034 Ada_Version
:= Ada_83
;
12035 Ada_Version_Explicit
:= Ada_83
;
12036 Ada_Version_Pragma
:= N
;
12045 -- Note: this pragma also has some specific processing in Par.Prag
12046 -- because we want to set the Ada 83 version mode during parsing.
12048 when Pragma_Ada_95
=>
12050 Check_Arg_Count
(0);
12052 -- We really should check unconditionally for proper configuration
12053 -- pragma placement, since we really don't want mixed Ada modes
12054 -- within a single unit, and the GNAT reference manual has always
12055 -- said this was a configuration pragma, but we did not check and
12056 -- are hesitant to add the check now.
12058 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12059 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12061 if Ada_Version
>= Ada_2005
then
12062 Check_Valid_Configuration_Pragma
;
12065 -- Now set Ada 95 mode
12067 if Latest_Ada_Only
then
12068 Error_Pragma
("??pragma% ignored");
12070 Ada_Version
:= Ada_95
;
12071 Ada_Version_Explicit
:= Ada_95
;
12072 Ada_Version_Pragma
:= N
;
12075 ---------------------
12076 -- Ada_05/Ada_2005 --
12077 ---------------------
12080 -- pragma Ada_05 (LOCAL_NAME);
12082 -- pragma Ada_2005;
12083 -- pragma Ada_2005 (LOCAL_NAME):
12085 -- Note: these pragmas also have some specific processing in Par.Prag
12086 -- because we want to set the Ada 2005 version mode during parsing.
12088 -- The one argument form is used for managing the transition from
12089 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12090 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12091 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12092 -- mode, a preference rule is established which does not choose
12093 -- such an entity unless it is unambiguously specified. This avoids
12094 -- extra subprograms marked this way from generating ambiguities in
12095 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12096 -- intended for exclusive use in the GNAT run-time library.
12107 if Arg_Count
= 1 then
12108 Check_Arg_Is_Local_Name
(Arg1
);
12109 E_Id
:= Get_Pragma_Arg
(Arg1
);
12111 if Etype
(E_Id
) = Any_Type
then
12115 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12116 Record_Rep_Item
(Entity
(E_Id
), N
);
12119 Check_Arg_Count
(0);
12121 -- For Ada_2005 we unconditionally enforce the documented
12122 -- configuration pragma placement, since we do not want to
12123 -- tolerate mixed modes in a unit involving Ada 2005. That
12124 -- would cause real difficulties for those cases where there
12125 -- are incompatibilities between Ada 95 and Ada 2005.
12127 Check_Valid_Configuration_Pragma
;
12129 -- Now set appropriate Ada mode
12131 if Latest_Ada_Only
then
12132 Error_Pragma
("??pragma% ignored");
12134 Ada_Version
:= Ada_2005
;
12135 Ada_Version_Explicit
:= Ada_2005
;
12136 Ada_Version_Pragma
:= N
;
12141 ---------------------
12142 -- Ada_12/Ada_2012 --
12143 ---------------------
12146 -- pragma Ada_12 (LOCAL_NAME);
12148 -- pragma Ada_2012;
12149 -- pragma Ada_2012 (LOCAL_NAME):
12151 -- Note: these pragmas also have some specific processing in Par.Prag
12152 -- because we want to set the Ada 2012 version mode during parsing.
12154 -- The one argument form is used for managing the transition from Ada
12155 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12156 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12157 -- mode will generate a warning. In addition, in any pre-Ada_2012
12158 -- mode, a preference rule is established which does not choose
12159 -- such an entity unless it is unambiguously specified. This avoids
12160 -- extra subprograms marked this way from generating ambiguities in
12161 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12162 -- intended for exclusive use in the GNAT run-time library.
12173 if Arg_Count
= 1 then
12174 Check_Arg_Is_Local_Name
(Arg1
);
12175 E_Id
:= Get_Pragma_Arg
(Arg1
);
12177 if Etype
(E_Id
) = Any_Type
then
12181 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12182 Record_Rep_Item
(Entity
(E_Id
), N
);
12185 Check_Arg_Count
(0);
12187 -- For Ada_2012 we unconditionally enforce the documented
12188 -- configuration pragma placement, since we do not want to
12189 -- tolerate mixed modes in a unit involving Ada 2012. That
12190 -- would cause real difficulties for those cases where there
12191 -- are incompatibilities between Ada 95 and Ada 2012. We could
12192 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12194 Check_Valid_Configuration_Pragma
;
12196 -- Now set appropriate Ada mode
12198 Ada_Version
:= Ada_2012
;
12199 Ada_Version_Explicit
:= Ada_2012
;
12200 Ada_Version_Pragma
:= N
;
12208 -- pragma Ada_2020;
12210 -- Note: this pragma also has some specific processing in Par.Prag
12211 -- because we want to set the Ada 2020 version mode during parsing.
12213 when Pragma_Ada_2020
=>
12216 Check_Arg_Count
(0);
12218 Check_Valid_Configuration_Pragma
;
12220 -- Now set appropriate Ada mode
12222 Ada_Version
:= Ada_2020
;
12223 Ada_Version_Explicit
:= Ada_2020
;
12224 Ada_Version_Pragma
:= N
;
12226 ----------------------
12227 -- All_Calls_Remote --
12228 ----------------------
12230 -- pragma All_Calls_Remote [(library_package_NAME)];
12232 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12233 Lib_Entity
: Entity_Id
;
12236 Check_Ada_83_Warning
;
12237 Check_Valid_Library_Unit_Pragma
;
12239 if Nkind
(N
) = N_Null_Statement
then
12243 Lib_Entity
:= Find_Lib_Unit_Name
;
12245 -- A pragma that applies to a Ghost entity becomes Ghost for the
12246 -- purposes of legality checks and removal of ignored Ghost code.
12248 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12250 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12252 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12253 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12254 Error_Pragma
("pragma% only apply to rci unit");
12256 -- Set flag for entity of the library unit
12259 Set_Has_All_Calls_Remote
(Lib_Entity
);
12262 end All_Calls_Remote
;
12264 ---------------------------
12265 -- Allow_Integer_Address --
12266 ---------------------------
12268 -- pragma Allow_Integer_Address;
12270 when Pragma_Allow_Integer_Address
=>
12272 Check_Valid_Configuration_Pragma
;
12273 Check_Arg_Count
(0);
12275 -- If Address is a private type, then set the flag to allow
12276 -- integer address values. If Address is not private, then this
12277 -- pragma has no purpose, so it is simply ignored. Not clear if
12278 -- there are any such targets now.
12280 if Opt
.Address_Is_Private
then
12281 Opt
.Allow_Integer_Address
:= True;
12289 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12290 -- ARG ::= NAME | EXPRESSION
12292 -- The first two arguments are by convention intended to refer to an
12293 -- external tool and a tool-specific function. These arguments are
12296 when Pragma_Annotate
=> Annotate
: declare
12303 Check_At_Least_N_Arguments
(1);
12305 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12307 -- Determine whether the last argument is "Entity => local_NAME"
12308 -- and if it is, perform the required semantic checks. Remove the
12309 -- argument from further processing.
12311 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12312 and then Chars
(Nam_Arg
) = Name_Entity
12314 Check_Arg_Is_Local_Name
(Nam_Arg
);
12315 Arg_Count
:= Arg_Count
- 1;
12317 -- A pragma that applies to a Ghost entity becomes Ghost for
12318 -- the purposes of legality checks and removal of ignored Ghost
12321 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12322 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12324 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12327 -- Not allowed in compiler units (bootstrap issues)
12329 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12332 -- Continue the processing with last argument removed for now
12334 Check_Arg_Is_Identifier
(Arg1
);
12335 Check_No_Identifiers
;
12338 -- The second parameter is optional, it is never analyzed
12343 -- Otherwise there is a second parameter
12346 -- The second parameter must be an identifier
12348 Check_Arg_Is_Identifier
(Arg2
);
12350 -- Process the remaining parameters (if any)
12352 Arg
:= Next
(Arg2
);
12353 while Present
(Arg
) loop
12354 Expr
:= Get_Pragma_Arg
(Arg
);
12357 if Is_Entity_Name
(Expr
) then
12360 -- For string literals, we assume Standard_String as the
12361 -- type, unless the string contains wide or wide_wide
12364 elsif Nkind
(Expr
) = N_String_Literal
then
12365 if Has_Wide_Wide_Character
(Expr
) then
12366 Resolve
(Expr
, Standard_Wide_Wide_String
);
12367 elsif Has_Wide_Character
(Expr
) then
12368 Resolve
(Expr
, Standard_Wide_String
);
12370 Resolve
(Expr
, Standard_String
);
12373 elsif Is_Overloaded
(Expr
) then
12374 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
12385 -------------------------------------------------
12386 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12387 -------------------------------------------------
12390 -- ( [Check => ] Boolean_EXPRESSION
12391 -- [, [Message =>] Static_String_EXPRESSION]);
12393 -- pragma Assert_And_Cut
12394 -- ( [Check => ] Boolean_EXPRESSION
12395 -- [, [Message =>] Static_String_EXPRESSION]);
12398 -- ( [Check => ] Boolean_EXPRESSION
12399 -- [, [Message =>] Static_String_EXPRESSION]);
12401 -- pragma Loop_Invariant
12402 -- ( [Check => ] Boolean_EXPRESSION
12403 -- [, [Message =>] Static_String_EXPRESSION]);
12406 | Pragma_Assert_And_Cut
12408 | Pragma_Loop_Invariant
12411 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
12412 -- Determine whether expression Expr contains a Loop_Entry
12413 -- attribute reference.
12415 -------------------------
12416 -- Contains_Loop_Entry --
12417 -------------------------
12419 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
12420 Has_Loop_Entry
: Boolean := False;
12422 function Process
(N
: Node_Id
) return Traverse_Result
;
12423 -- Process function for traversal to look for Loop_Entry
12429 function Process
(N
: Node_Id
) return Traverse_Result
is
12431 if Nkind
(N
) = N_Attribute_Reference
12432 and then Attribute_Name
(N
) = Name_Loop_Entry
12434 Has_Loop_Entry
:= True;
12441 procedure Traverse
is new Traverse_Proc
(Process
);
12443 -- Start of processing for Contains_Loop_Entry
12447 return Has_Loop_Entry
;
12448 end Contains_Loop_Entry
;
12453 New_Args
: List_Id
;
12455 -- Start of processing for Assert
12458 -- Assert is an Ada 2005 RM-defined pragma
12460 if Prag_Id
= Pragma_Assert
then
12463 -- The remaining ones are GNAT pragmas
12469 Check_At_Least_N_Arguments
(1);
12470 Check_At_Most_N_Arguments
(2);
12471 Check_Arg_Order
((Name_Check
, Name_Message
));
12472 Check_Optional_Identifier
(Arg1
, Name_Check
);
12473 Expr
:= Get_Pragma_Arg
(Arg1
);
12475 -- Special processing for Loop_Invariant, Loop_Variant or for
12476 -- other cases where a Loop_Entry attribute is present. If the
12477 -- assertion pragma contains attribute Loop_Entry, ensure that
12478 -- the related pragma is within a loop.
12480 if Prag_Id
= Pragma_Loop_Invariant
12481 or else Prag_Id
= Pragma_Loop_Variant
12482 or else Contains_Loop_Entry
(Expr
)
12484 Check_Loop_Pragma_Placement
;
12486 -- Perform preanalysis to deal with embedded Loop_Entry
12489 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
12492 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12493 -- a corresponding Check pragma:
12495 -- pragma Check (name, condition [, msg]);
12497 -- Where name is the identifier matching the pragma name. So
12498 -- rewrite pragma in this manner, transfer the message argument
12499 -- if present, and analyze the result
12501 -- Note: When dealing with a semantically analyzed tree, the
12502 -- information that a Check node N corresponds to a source Assert,
12503 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12504 -- pragma kind of Original_Node(N).
12506 New_Args
:= New_List
(
12507 Make_Pragma_Argument_Association
(Loc
,
12508 Expression
=> Make_Identifier
(Loc
, Pname
)),
12509 Make_Pragma_Argument_Association
(Sloc
(Expr
),
12510 Expression
=> Expr
));
12512 if Arg_Count
> 1 then
12513 Check_Optional_Identifier
(Arg2
, Name_Message
);
12515 -- Provide semantic annnotations for optional argument, for
12516 -- ASIS use, before rewriting.
12518 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
12519 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
12522 -- Rewrite as Check pragma
12526 Chars
=> Name_Check
,
12527 Pragma_Argument_Associations
=> New_Args
));
12532 ----------------------
12533 -- Assertion_Policy --
12534 ----------------------
12536 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12538 -- The following form is Ada 2012 only, but we allow it in all modes
12540 -- Pragma Assertion_Policy (
12541 -- ASSERTION_KIND => POLICY_IDENTIFIER
12542 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12544 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12546 -- RM_ASSERTION_KIND ::= Assert |
12547 -- Static_Predicate |
12548 -- Dynamic_Predicate |
12553 -- Type_Invariant |
12554 -- Type_Invariant'Class
12556 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12558 -- Contract_Cases |
12560 -- Default_Initial_Condition |
12562 -- Initial_Condition |
12563 -- Loop_Invariant |
12569 -- Statement_Assertions
12571 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12572 -- ID_ASSERTION_KIND list contains implementation-defined additions
12573 -- recognized by GNAT. The effect is to control the behavior of
12574 -- identically named aspects and pragmas, depending on the specified
12575 -- policy identifier:
12577 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12579 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12580 -- implementation-defined addition that results in totally ignoring
12581 -- the corresponding assertion. If Disable is specified, then the
12582 -- argument of the assertion is not even analyzed. This is useful
12583 -- when the aspect/pragma argument references entities in a with'ed
12584 -- package that is replaced by a dummy package in the final build.
12586 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12587 -- and Type_Invariant'Class were recognized by the parser and
12588 -- transformed into references to the special internal identifiers
12589 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12590 -- processing is required here.
12592 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12593 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12594 -- Converts the assertion policy 'Suppressible' to either Check or
12595 -- Ignore based on whether checks are suppressed via -gnatp.
12597 --------------------------
12598 -- Resolve_Suppressible --
12599 --------------------------
12601 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12602 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12606 -- Transform policy argument Suppressible into either Ignore or
12607 -- Check depending on whether checks are enabled or suppressed.
12609 if Chars
(Arg
) = Name_Suppressible
then
12610 if Suppress_Checks
then
12611 Nam
:= Name_Ignore
;
12616 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12618 end Resolve_Suppressible
;
12630 -- This can always appear as a configuration pragma
12632 if Is_Configuration_Pragma
then
12635 -- It can also appear in a declarative part or package spec in Ada
12636 -- 2012 mode. We allow this in other modes, but in that case we
12637 -- consider that we have an Ada 2012 pragma on our hands.
12640 Check_Is_In_Decl_Part_Or_Package_Spec
;
12644 -- One argument case with no identifier (first form above)
12647 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12648 or else Chars
(Arg1
) = No_Name
)
12650 Check_Arg_Is_One_Of
(Arg1
,
12651 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12653 Resolve_Suppressible
(Arg1
);
12655 -- Treat one argument Assertion_Policy as equivalent to:
12657 -- pragma Check_Policy (Assertion, policy)
12659 -- So rewrite pragma in that manner and link on to the chain
12660 -- of Check_Policy pragmas, marking the pragma as analyzed.
12662 Policy
:= Get_Pragma_Arg
(Arg1
);
12666 Chars
=> Name_Check_Policy
,
12667 Pragma_Argument_Associations
=> New_List
(
12668 Make_Pragma_Argument_Association
(Loc
,
12669 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12671 Make_Pragma_Argument_Association
(Loc
,
12673 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12676 -- Here if we have two or more arguments
12679 Check_At_Least_N_Arguments
(1);
12682 -- Loop through arguments
12685 while Present
(Arg
) loop
12686 LocP
:= Sloc
(Arg
);
12688 -- Kind must be specified
12690 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12691 or else Chars
(Arg
) = No_Name
12694 ("missing assertion kind for pragma%", Arg
);
12697 -- Check Kind and Policy have allowed forms
12699 Kind
:= Chars
(Arg
);
12700 Policy
:= Get_Pragma_Arg
(Arg
);
12702 if not Is_Valid_Assertion_Kind
(Kind
) then
12704 ("invalid assertion kind for pragma%", Arg
);
12707 Check_Arg_Is_One_Of
(Arg
,
12708 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12710 Resolve_Suppressible
(Arg
);
12712 if Kind
= Name_Ghost
then
12714 -- The Ghost policy must be either Check or Ignore
12715 -- (SPARK RM 6.9(6)).
12717 if not Nam_In
(Chars
(Policy
), Name_Check
,
12721 ("argument of pragma % Ghost must be Check or "
12722 & "Ignore", Policy
);
12725 -- Pragma Assertion_Policy specifying a Ghost policy
12726 -- cannot occur within a Ghost subprogram or package
12727 -- (SPARK RM 6.9(14)).
12729 if Ghost_Mode
> None
then
12731 ("pragma % cannot appear within ghost subprogram or "
12736 -- Rewrite the Assertion_Policy pragma as a series of
12737 -- Check_Policy pragmas of the form:
12739 -- Check_Policy (Kind, Policy);
12741 -- Note: the insertion of the pragmas cannot be done with
12742 -- Insert_Action because in the configuration case, there
12743 -- are no scopes on the scope stack and the mechanism will
12746 Insert_Before_And_Analyze
(N
,
12748 Chars
=> Name_Check_Policy
,
12749 Pragma_Argument_Associations
=> New_List
(
12750 Make_Pragma_Argument_Association
(LocP
,
12751 Expression
=> Make_Identifier
(LocP
, Kind
)),
12752 Make_Pragma_Argument_Association
(LocP
,
12753 Expression
=> Policy
))));
12758 -- Rewrite the Assertion_Policy pragma as null since we have
12759 -- now inserted all the equivalent Check pragmas.
12761 Rewrite
(N
, Make_Null_Statement
(Loc
));
12764 end Assertion_Policy
;
12766 ------------------------------
12767 -- Assume_No_Invalid_Values --
12768 ------------------------------
12770 -- pragma Assume_No_Invalid_Values (On | Off);
12772 when Pragma_Assume_No_Invalid_Values
=>
12774 Check_Valid_Configuration_Pragma
;
12775 Check_Arg_Count
(1);
12776 Check_No_Identifiers
;
12777 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12779 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12780 Assume_No_Invalid_Values
:= True;
12782 Assume_No_Invalid_Values
:= False;
12785 --------------------------
12786 -- Attribute_Definition --
12787 --------------------------
12789 -- pragma Attribute_Definition
12790 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12791 -- [Entity =>] LOCAL_NAME,
12792 -- [Expression =>] EXPRESSION | NAME);
12794 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12795 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12800 Check_Arg_Count
(3);
12801 Check_Optional_Identifier
(Arg1
, "attribute");
12802 Check_Optional_Identifier
(Arg2
, "entity");
12803 Check_Optional_Identifier
(Arg3
, "expression");
12805 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12806 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12810 Check_Arg_Is_Local_Name
(Arg2
);
12812 -- If the attribute is not recognized, then issue a warning (not
12813 -- an error), and ignore the pragma.
12815 Aname
:= Chars
(Attribute_Designator
);
12817 if not Is_Attribute_Name
(Aname
) then
12818 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12822 -- Otherwise, rewrite the pragma as an attribute definition clause
12825 Make_Attribute_Definition_Clause
(Loc
,
12826 Name
=> Get_Pragma_Arg
(Arg2
),
12828 Expression
=> Get_Pragma_Arg
(Arg3
)));
12830 end Attribute_Definition
;
12832 ------------------------------------------------------------------
12833 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12834 ------------------------------------------------------------------
12836 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12837 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12838 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12839 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12841 when Pragma_Async_Readers
12842 | Pragma_Async_Writers
12843 | Pragma_Effective_Reads
12844 | Pragma_Effective_Writes
12846 Async_Effective
: declare
12847 Obj_Decl
: Node_Id
;
12848 Obj_Id
: Entity_Id
;
12852 Check_No_Identifiers
;
12853 Check_At_Most_N_Arguments
(1);
12855 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12857 -- Object declaration
12859 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
12864 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12866 -- Perform minimal verification to ensure that the argument is at
12867 -- least a variable. Subsequent finer grained checks will be done
12868 -- at the end of the declarative region the contains the pragma.
12870 if Ekind
(Obj_Id
) = E_Variable
then
12872 -- A pragma that applies to a Ghost entity becomes Ghost for
12873 -- the purposes of legality checks and removal of ignored Ghost
12876 Mark_Ghost_Pragma
(N
, Obj_Id
);
12878 -- Chain the pragma on the contract for further processing by
12879 -- Analyze_External_Property_In_Decl_Part.
12881 Add_Contract_Item
(N
, Obj_Id
);
12883 -- Analyze the Boolean expression (if any)
12885 if Present
(Arg1
) then
12886 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12889 -- Otherwise the external property applies to a constant
12892 Error_Pragma
("pragma % must apply to a volatile object");
12894 end Async_Effective
;
12900 -- pragma Asynchronous (LOCAL_NAME);
12902 when Pragma_Asynchronous
=> Asynchronous
: declare
12905 Formal
: Entity_Id
;
12910 procedure Process_Async_Pragma
;
12911 -- Common processing for procedure and access-to-procedure case
12913 --------------------------
12914 -- Process_Async_Pragma --
12915 --------------------------
12917 procedure Process_Async_Pragma
is
12920 Set_Is_Asynchronous
(Nm
);
12924 -- The formals should be of mode IN (RM E.4.1(6))
12927 while Present
(S
) loop
12928 Formal
:= Defining_Identifier
(S
);
12930 if Nkind
(Formal
) = N_Defining_Identifier
12931 and then Ekind
(Formal
) /= E_In_Parameter
12934 ("pragma% procedure can only have IN parameter",
12941 Set_Is_Asynchronous
(Nm
);
12942 end Process_Async_Pragma
;
12944 -- Start of processing for pragma Asynchronous
12947 Check_Ada_83_Warning
;
12948 Check_No_Identifiers
;
12949 Check_Arg_Count
(1);
12950 Check_Arg_Is_Local_Name
(Arg1
);
12952 if Debug_Flag_U
then
12956 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12957 Analyze
(Get_Pragma_Arg
(Arg1
));
12958 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12960 -- A pragma that applies to a Ghost entity becomes Ghost for the
12961 -- purposes of legality checks and removal of ignored Ghost code.
12963 Mark_Ghost_Pragma
(N
, Nm
);
12965 if not Is_Remote_Call_Interface
(C_Ent
)
12966 and then not Is_Remote_Types
(C_Ent
)
12968 -- This pragma should only appear in an RCI or Remote Types
12969 -- unit (RM E.4.1(4)).
12972 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12975 if Ekind
(Nm
) = E_Procedure
12976 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12978 if not Is_Remote_Call_Interface
(Nm
) then
12980 ("pragma% cannot be applied on non-remote procedure",
12984 L
:= Parameter_Specifications
(Parent
(Nm
));
12985 Process_Async_Pragma
;
12988 elsif Ekind
(Nm
) = E_Function
then
12990 ("pragma% cannot be applied to function", Arg1
);
12992 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12993 if Is_Record_Type
(Nm
) then
12995 -- A record type that is the Equivalent_Type for a remote
12996 -- access-to-subprogram type.
12998 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13001 -- A non-expanded RAS type (distribution is not enabled)
13003 Decl
:= Declaration_Node
(Nm
);
13006 if Nkind
(Decl
) = N_Full_Type_Declaration
13007 and then Nkind
(Type_Definition
(Decl
)) =
13008 N_Access_Procedure_Definition
13010 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13011 Process_Async_Pragma
;
13013 if Is_Asynchronous
(Nm
)
13014 and then Expander_Active
13015 and then Get_PCS_Name
/= Name_No_DSA
13017 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13022 ("pragma% cannot reference access-to-function type",
13026 -- Only other possibility is Access-to-class-wide type
13028 elsif Is_Access_Type
(Nm
)
13029 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13031 Check_First_Subtype
(Arg1
);
13032 Set_Is_Asynchronous
(Nm
);
13033 if Expander_Active
then
13034 RACW_Type_Is_Asynchronous
(Nm
);
13038 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13046 -- pragma Atomic (LOCAL_NAME);
13048 when Pragma_Atomic
=>
13049 Process_Atomic_Independent_Shared_Volatile
;
13051 -----------------------
13052 -- Atomic_Components --
13053 -----------------------
13055 -- pragma Atomic_Components (array_LOCAL_NAME);
13057 -- This processing is shared by Volatile_Components
13059 when Pragma_Atomic_Components
13060 | Pragma_Volatile_Components
13062 Atomic_Components
: declare
13069 Check_Ada_83_Warning
;
13070 Check_No_Identifiers
;
13071 Check_Arg_Count
(1);
13072 Check_Arg_Is_Local_Name
(Arg1
);
13073 E_Id
:= Get_Pragma_Arg
(Arg1
);
13075 if Etype
(E_Id
) = Any_Type
then
13079 E
:= Entity
(E_Id
);
13081 -- A pragma that applies to a Ghost entity becomes Ghost for the
13082 -- purposes of legality checks and removal of ignored Ghost code.
13084 Mark_Ghost_Pragma
(N
, E
);
13085 Check_Duplicate_Pragma
(E
);
13087 if Rep_Item_Too_Early
(E
, N
)
13089 Rep_Item_Too_Late
(E
, N
)
13094 D
:= Declaration_Node
(E
);
13097 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13099 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13100 and then Nkind
(D
) = N_Object_Declaration
13101 and then Nkind
(Object_Definition
(D
)) =
13102 N_Constrained_Array_Definition
)
13104 -- The flag is set on the object, or on the base type
13106 if Nkind
(D
) /= N_Object_Declaration
then
13107 E
:= Base_Type
(E
);
13110 -- Atomic implies both Independent and Volatile
13112 if Prag_Id
= Pragma_Atomic_Components
then
13113 Set_Has_Atomic_Components
(E
);
13114 Set_Has_Independent_Components
(E
);
13117 Set_Has_Volatile_Components
(E
);
13120 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13122 end Atomic_Components
;
13124 --------------------
13125 -- Attach_Handler --
13126 --------------------
13128 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13130 when Pragma_Attach_Handler
=>
13131 Check_Ada_83_Warning
;
13132 Check_No_Identifiers
;
13133 Check_Arg_Count
(2);
13135 if No_Run_Time_Mode
then
13136 Error_Msg_CRT
("Attach_Handler pragma", N
);
13138 Check_Interrupt_Or_Attach_Handler
;
13140 -- The expression that designates the attribute may depend on a
13141 -- discriminant, and is therefore a per-object expression, to
13142 -- be expanded in the init proc. If expansion is enabled, then
13143 -- perform semantic checks on a copy only.
13148 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13151 -- In Relaxed_RM_Semantics mode, we allow any static
13152 -- integer value, for compatibility with other compilers.
13154 if Relaxed_RM_Semantics
13155 and then Nkind
(Parg2
) = N_Integer_Literal
13157 Typ
:= Standard_Integer
;
13159 Typ
:= RTE
(RE_Interrupt_ID
);
13162 if Expander_Active
then
13163 Temp
:= New_Copy_Tree
(Parg2
);
13164 Set_Parent
(Temp
, N
);
13165 Preanalyze_And_Resolve
(Temp
, Typ
);
13168 Resolve
(Parg2
, Typ
);
13172 Process_Interrupt_Or_Attach_Handler
;
13175 --------------------
13176 -- C_Pass_By_Copy --
13177 --------------------
13179 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13181 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13187 Check_Valid_Configuration_Pragma
;
13188 Check_Arg_Count
(1);
13189 Check_Optional_Identifier
(Arg1
, "max_size");
13191 Arg
:= Get_Pragma_Arg
(Arg1
);
13192 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13194 Val
:= Expr_Value
(Arg
);
13198 ("maximum size for pragma% must be positive", Arg1
);
13200 elsif UI_Is_In_Int_Range
(Val
) then
13201 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13203 -- If a giant value is given, Int'Last will do well enough.
13204 -- If sometime someone complains that a record larger than
13205 -- two gigabytes is not copied, we will worry about it then.
13208 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13210 end C_Pass_By_Copy
;
13216 -- pragma Check ([Name =>] CHECK_KIND,
13217 -- [Check =>] Boolean_EXPRESSION
13218 -- [,[Message =>] String_EXPRESSION]);
13220 -- CHECK_KIND ::= IDENTIFIER |
13223 -- Invariant'Class |
13224 -- Type_Invariant'Class
13226 -- The identifiers Assertions and Statement_Assertions are not
13227 -- allowed, since they have special meaning for Check_Policy.
13229 -- WARNING: The code below manages Ghost regions. Return statements
13230 -- must be replaced by gotos which jump to the end of the code and
13231 -- restore the Ghost mode.
13233 when Pragma_Check
=> Check
: declare
13234 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13235 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13236 -- Save the Ghost-related attributes to restore on exit
13242 pragma Warnings
(Off
, Str
);
13245 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13246 -- the mode now to ensure that any nodes generated during analysis
13247 -- and expansion are marked as Ghost.
13249 Set_Ghost_Mode
(N
);
13252 Check_At_Least_N_Arguments
(2);
13253 Check_At_Most_N_Arguments
(3);
13254 Check_Optional_Identifier
(Arg1
, Name_Name
);
13255 Check_Optional_Identifier
(Arg2
, Name_Check
);
13257 if Arg_Count
= 3 then
13258 Check_Optional_Identifier
(Arg3
, Name_Message
);
13259 Str
:= Get_Pragma_Arg
(Arg3
);
13262 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13263 Check_Arg_Is_Identifier
(Arg1
);
13264 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13266 -- Check forbidden name Assertions or Statement_Assertions
13269 when Name_Assertions
=>
13271 ("""Assertions"" is not allowed as a check kind for "
13272 & "pragma%", Arg1
);
13274 when Name_Statement_Assertions
=>
13276 ("""Statement_Assertions"" is not allowed as a check kind "
13277 & "for pragma%", Arg1
);
13283 -- Check applicable policy. We skip this if Checked/Ignored status
13284 -- is already set (e.g. in the case of a pragma from an aspect).
13286 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13289 -- For a non-source pragma that is a rewriting of another pragma,
13290 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13292 elsif Is_Rewrite_Substitution
(N
)
13293 and then Nkind
(Original_Node
(N
)) = N_Pragma
13294 and then Original_Node
(N
) /= N
13296 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13297 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13299 -- Otherwise query the applicable policy at this point
13302 case Check_Kind
(Cname
) is
13303 when Name_Ignore
=>
13304 Set_Is_Ignored
(N
, True);
13305 Set_Is_Checked
(N
, False);
13308 Set_Is_Ignored
(N
, False);
13309 Set_Is_Checked
(N
, True);
13311 -- For disable, rewrite pragma as null statement and skip
13312 -- rest of the analysis of the pragma.
13314 when Name_Disable
=>
13315 Rewrite
(N
, Make_Null_Statement
(Loc
));
13319 -- No other possibilities
13322 raise Program_Error
;
13326 -- If check kind was not Disable, then continue pragma analysis
13328 Expr
:= Get_Pragma_Arg
(Arg2
);
13330 -- Deal with SCO generation
13332 if Is_Checked
(N
) and then not Split_PPC
(N
) then
13333 Set_SCO_Pragma_Enabled
(Loc
);
13336 -- Deal with analyzing the string argument. If checks are not
13337 -- on we don't want any expansion (since such expansion would
13338 -- not get properly deleted) but we do want to analyze (to get
13339 -- proper references). The Preanalyze_And_Resolve routine does
13340 -- just what we want. Ditto if pragma is active, because it will
13341 -- be rewritten as an if-statement whose analysis will complete
13342 -- analysis and expansion of the string message. This makes a
13343 -- difference in the unusual case where the expression for the
13344 -- string may have a side effect, such as raising an exception.
13345 -- This is mandated by RM 11.4.2, which specifies that the string
13346 -- expression is only evaluated if the check fails and
13347 -- Assertion_Error is to be raised.
13349 if Arg_Count
= 3 then
13350 Preanalyze_And_Resolve
(Str
, Standard_String
);
13353 -- Now you might think we could just do the same with the Boolean
13354 -- expression if checks are off (and expansion is on) and then
13355 -- rewrite the check as a null statement. This would work but we
13356 -- would lose the useful warnings about an assertion being bound
13357 -- to fail even if assertions are turned off.
13359 -- So instead we wrap the boolean expression in an if statement
13360 -- that looks like:
13362 -- if False and then condition then
13366 -- The reason we do this rewriting during semantic analysis rather
13367 -- than as part of normal expansion is that we cannot analyze and
13368 -- expand the code for the boolean expression directly, or it may
13369 -- cause insertion of actions that would escape the attempt to
13370 -- suppress the check code.
13372 -- Note that the Sloc for the if statement corresponds to the
13373 -- argument condition, not the pragma itself. The reason for
13374 -- this is that we may generate a warning if the condition is
13375 -- False at compile time, and we do not want to delete this
13376 -- warning when we delete the if statement.
13378 if Expander_Active
and Is_Ignored
(N
) then
13379 Eloc
:= Sloc
(Expr
);
13382 Make_If_Statement
(Eloc
,
13384 Make_And_Then
(Eloc
,
13385 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
13386 Right_Opnd
=> Expr
),
13387 Then_Statements
=> New_List
(
13388 Make_Null_Statement
(Eloc
))));
13390 -- Now go ahead and analyze the if statement
13392 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13394 -- One rather special treatment. If we are now in Eliminated
13395 -- overflow mode, then suppress overflow checking since we do
13396 -- not want to drag in the bignum stuff if we are in Ignore
13397 -- mode anyway. This is particularly important if we are using
13398 -- a configurable run time that does not support bignum ops.
13400 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
13402 Svo
: constant Boolean :=
13403 Scope_Suppress
.Suppress
(Overflow_Check
);
13405 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
13406 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
13408 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
13409 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
13412 -- Not that special case
13418 -- All done with this check
13420 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13422 -- Check is active or expansion not active. In these cases we can
13423 -- just go ahead and analyze the boolean with no worries.
13426 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13427 Analyze_And_Resolve
(Expr
, Any_Boolean
);
13428 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13431 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
13434 --------------------------
13435 -- Check_Float_Overflow --
13436 --------------------------
13438 -- pragma Check_Float_Overflow;
13440 when Pragma_Check_Float_Overflow
=>
13442 Check_Valid_Configuration_Pragma
;
13443 Check_Arg_Count
(0);
13444 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
13450 -- pragma Check_Name (check_IDENTIFIER);
13452 when Pragma_Check_Name
=>
13454 Check_No_Identifiers
;
13455 Check_Valid_Configuration_Pragma
;
13456 Check_Arg_Count
(1);
13457 Check_Arg_Is_Identifier
(Arg1
);
13460 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
13463 for J
in Check_Names
.First
.. Check_Names
.Last
loop
13464 if Check_Names
.Table
(J
) = Nam
then
13469 Check_Names
.Append
(Nam
);
13476 -- This is the old style syntax, which is still allowed in all modes:
13478 -- pragma Check_Policy ([Name =>] CHECK_KIND
13479 -- [Policy =>] POLICY_IDENTIFIER);
13481 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13483 -- CHECK_KIND ::= IDENTIFIER |
13486 -- Type_Invariant'Class |
13489 -- This is the new style syntax, compatible with Assertion_Policy
13490 -- and also allowed in all modes.
13492 -- Pragma Check_Policy (
13493 -- CHECK_KIND => POLICY_IDENTIFIER
13494 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13496 -- Note: the identifiers Name and Policy are not allowed as
13497 -- Check_Kind values. This avoids ambiguities between the old and
13498 -- new form syntax.
13500 when Pragma_Check_Policy
=> Check_Policy
: declare
13505 Check_At_Least_N_Arguments
(1);
13507 -- A Check_Policy pragma can appear either as a configuration
13508 -- pragma, or in a declarative part or a package spec (see RM
13509 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13510 -- followed for Check_Policy).
13512 if not Is_Configuration_Pragma
then
13513 Check_Is_In_Decl_Part_Or_Package_Spec
;
13516 -- Figure out if we have the old or new syntax. We have the
13517 -- old syntax if the first argument has no identifier, or the
13518 -- identifier is Name.
13520 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
13521 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
13525 Check_Arg_Count
(2);
13526 Check_Optional_Identifier
(Arg1
, Name_Name
);
13527 Kind
:= Get_Pragma_Arg
(Arg1
);
13528 Rewrite_Assertion_Kind
(Kind
,
13529 From_Policy
=> Comes_From_Source
(N
));
13530 Check_Arg_Is_Identifier
(Arg1
);
13532 -- Check forbidden check kind
13534 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
13535 Error_Msg_Name_2
:= Chars
(Kind
);
13537 ("pragma% does not allow% as check name", Arg1
);
13542 Check_Optional_Identifier
(Arg2
, Name_Policy
);
13543 Check_Arg_Is_One_Of
13545 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
13547 -- And chain pragma on the Check_Policy_List for search
13549 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
13550 Opt
.Check_Policy_List
:= N
;
13552 -- For the new syntax, what we do is to convert each argument to
13553 -- an old syntax equivalent. We do that because we want to chain
13554 -- old style Check_Policy pragmas for the search (we don't want
13555 -- to have to deal with multiple arguments in the search).
13566 while Present
(Arg
) loop
13567 LocP
:= Sloc
(Arg
);
13568 Argx
:= Get_Pragma_Arg
(Arg
);
13570 -- Kind must be specified
13572 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13573 or else Chars
(Arg
) = No_Name
13576 ("missing assertion kind for pragma%", Arg
);
13579 -- Construct equivalent old form syntax Check_Policy
13580 -- pragma and insert it to get remaining checks.
13584 Chars
=> Name_Check_Policy
,
13585 Pragma_Argument_Associations
=> New_List
(
13586 Make_Pragma_Argument_Association
(LocP
,
13588 Make_Identifier
(LocP
, Chars
(Arg
))),
13589 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13590 Expression
=> Argx
)));
13594 -- For a configuration pragma, insert old form in
13595 -- the corresponding file.
13597 if Is_Configuration_Pragma
then
13598 Insert_After
(N
, New_P
);
13602 Insert_Action
(N
, New_P
);
13606 -- Rewrite original Check_Policy pragma to null, since we
13607 -- have converted it into a series of old syntax pragmas.
13609 Rewrite
(N
, Make_Null_Statement
(Loc
));
13619 -- pragma Comment (static_string_EXPRESSION)
13621 -- Processing for pragma Comment shares the circuitry for pragma
13622 -- Ident. The only differences are that Ident enforces a limit of 31
13623 -- characters on its argument, and also enforces limitations on
13624 -- placement for DEC compatibility. Pragma Comment shares neither of
13625 -- these restrictions.
13627 -------------------
13628 -- Common_Object --
13629 -------------------
13631 -- pragma Common_Object (
13632 -- [Internal =>] LOCAL_NAME
13633 -- [, [External =>] EXTERNAL_SYMBOL]
13634 -- [, [Size =>] EXTERNAL_SYMBOL]);
13636 -- Processing for this pragma is shared with Psect_Object
13638 ------------------------
13639 -- Compile_Time_Error --
13640 ------------------------
13642 -- pragma Compile_Time_Error
13643 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13645 when Pragma_Compile_Time_Error
=>
13647 Process_Compile_Time_Warning_Or_Error
;
13649 --------------------------
13650 -- Compile_Time_Warning --
13651 --------------------------
13653 -- pragma Compile_Time_Warning
13654 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13656 when Pragma_Compile_Time_Warning
=>
13658 Process_Compile_Time_Warning_Or_Error
;
13660 ---------------------------
13661 -- Compiler_Unit_Warning --
13662 ---------------------------
13664 -- pragma Compiler_Unit_Warning;
13668 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13669 -- errors not warnings. This means that we had introduced a big extra
13670 -- inertia to compiler changes, since even if we implemented a new
13671 -- feature, and even if all versions to be used for bootstrapping
13672 -- implemented this new feature, we could not use it, since old
13673 -- compilers would give errors for using this feature in units
13674 -- having Compiler_Unit pragmas.
13676 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13677 -- problem. We no longer have any units mentioning Compiler_Unit,
13678 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13679 -- and thus generates a warning which can be ignored. So that deals
13680 -- with the problem of old compilers not implementing the newer form
13683 -- Newer compilers recognize the new pragma, but generate warning
13684 -- messages instead of errors, which again can be ignored in the
13685 -- case of an old compiler which implements a wanted new feature
13686 -- but at the time felt like warning about it for older compilers.
13688 -- We retain Compiler_Unit so that new compilers can be used to build
13689 -- older run-times that use this pragma. That's an unusual case, but
13690 -- it's easy enough to handle, so why not?
13692 when Pragma_Compiler_Unit
13693 | Pragma_Compiler_Unit_Warning
13696 Check_Arg_Count
(0);
13698 -- Only recognized in main unit
13700 if Current_Sem_Unit
= Main_Unit
then
13701 Compiler_Unit
:= True;
13704 -----------------------------
13705 -- Complete_Representation --
13706 -----------------------------
13708 -- pragma Complete_Representation;
13710 when Pragma_Complete_Representation
=>
13712 Check_Arg_Count
(0);
13714 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13716 ("pragma & must appear within record representation clause");
13719 ----------------------------
13720 -- Complex_Representation --
13721 ----------------------------
13723 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13725 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13732 Check_Arg_Count
(1);
13733 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13734 Check_Arg_Is_Local_Name
(Arg1
);
13735 E_Id
:= Get_Pragma_Arg
(Arg1
);
13737 if Etype
(E_Id
) = Any_Type
then
13741 E
:= Entity
(E_Id
);
13743 if not Is_Record_Type
(E
) then
13745 ("argument for pragma% must be record type", Arg1
);
13748 Ent
:= First_Entity
(E
);
13751 or else No
(Next_Entity
(Ent
))
13752 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13753 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13754 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13757 ("record for pragma% must have two fields of the same "
13758 & "floating-point type", Arg1
);
13761 Set_Has_Complex_Representation
(Base_Type
(E
));
13763 -- We need to treat the type has having a non-standard
13764 -- representation, for back-end purposes, even though in
13765 -- general a complex will have the default representation
13766 -- of a record with two real components.
13768 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13770 end Complex_Representation
;
13772 -------------------------
13773 -- Component_Alignment --
13774 -------------------------
13776 -- pragma Component_Alignment (
13777 -- [Form =>] ALIGNMENT_CHOICE
13778 -- [, [Name =>] type_LOCAL_NAME]);
13780 -- ALIGNMENT_CHOICE ::=
13782 -- | Component_Size_4
13786 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13787 Args
: Args_List
(1 .. 2);
13788 Names
: constant Name_List
(1 .. 2) := (
13792 Form
: Node_Id
renames Args
(1);
13793 Name
: Node_Id
renames Args
(2);
13795 Atype
: Component_Alignment_Kind
;
13800 Gather_Associations
(Names
, Args
);
13803 Error_Pragma
("missing Form argument for pragma%");
13806 Check_Arg_Is_Identifier
(Form
);
13808 -- Get proper alignment, note that Default = Component_Size on all
13809 -- machines we have so far, and we want to set this value rather
13810 -- than the default value to indicate that it has been explicitly
13811 -- set (and thus will not get overridden by the default component
13812 -- alignment for the current scope)
13814 if Chars
(Form
) = Name_Component_Size
then
13815 Atype
:= Calign_Component_Size
;
13817 elsif Chars
(Form
) = Name_Component_Size_4
then
13818 Atype
:= Calign_Component_Size_4
;
13820 elsif Chars
(Form
) = Name_Default
then
13821 Atype
:= Calign_Component_Size
;
13823 elsif Chars
(Form
) = Name_Storage_Unit
then
13824 Atype
:= Calign_Storage_Unit
;
13828 ("invalid Form parameter for pragma%", Form
);
13831 -- The pragma appears in a configuration file
13833 if No
(Parent
(N
)) then
13834 Check_Valid_Configuration_Pragma
;
13836 -- Capture the component alignment in a global variable when
13837 -- the pragma appears in a configuration file. Note that the
13838 -- scope stack is empty at this point and cannot be used to
13839 -- store the alignment value.
13841 Configuration_Component_Alignment
:= Atype
;
13843 -- Case with no name, supplied, affects scope table entry
13845 elsif No
(Name
) then
13847 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13849 -- Case of name supplied
13852 Check_Arg_Is_Local_Name
(Name
);
13854 Typ
:= Entity
(Name
);
13857 or else Rep_Item_Too_Early
(Typ
, N
)
13861 Typ
:= Underlying_Type
(Typ
);
13864 if not Is_Record_Type
(Typ
)
13865 and then not Is_Array_Type
(Typ
)
13868 ("Name parameter of pragma% must identify record or "
13869 & "array type", Name
);
13872 -- An explicit Component_Alignment pragma overrides an
13873 -- implicit pragma Pack, but not an explicit one.
13875 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13876 Set_Is_Packed
(Base_Type
(Typ
), False);
13877 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13880 end Component_AlignmentP
;
13882 --------------------------------
13883 -- Constant_After_Elaboration --
13884 --------------------------------
13886 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13888 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13890 Obj_Decl
: Node_Id
;
13891 Obj_Id
: Entity_Id
;
13895 Check_No_Identifiers
;
13896 Check_At_Most_N_Arguments
(1);
13898 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13900 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
13905 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13907 -- The object declaration must be a library-level variable which
13908 -- is either explicitly initialized or obtains a value during the
13909 -- elaboration of a package body (SPARK RM 3.3.1).
13911 if Ekind
(Obj_Id
) = E_Variable
then
13912 if not Is_Library_Level_Entity
(Obj_Id
) then
13914 ("pragma % must apply to a library level variable");
13918 -- Otherwise the pragma applies to a constant, which is illegal
13921 Error_Pragma
("pragma % must apply to a variable declaration");
13925 -- A pragma that applies to a Ghost entity becomes Ghost for the
13926 -- purposes of legality checks and removal of ignored Ghost code.
13928 Mark_Ghost_Pragma
(N
, Obj_Id
);
13930 -- Chain the pragma on the contract for completeness
13932 Add_Contract_Item
(N
, Obj_Id
);
13934 -- Analyze the Boolean expression (if any)
13936 if Present
(Arg1
) then
13937 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13939 end Constant_After_Elaboration
;
13941 --------------------
13942 -- Contract_Cases --
13943 --------------------
13945 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13947 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13949 -- CASE_GUARD ::= boolean_EXPRESSION | others
13951 -- CONSEQUENCE ::= boolean_EXPRESSION
13953 -- Characteristics:
13955 -- * Analysis - The annotation undergoes initial checks to verify
13956 -- the legal placement and context. Secondary checks preanalyze the
13959 -- Analyze_Contract_Cases_In_Decl_Part
13961 -- * Expansion - The annotation is expanded during the expansion of
13962 -- the related subprogram [body] contract as performed in:
13964 -- Expand_Subprogram_Contract
13966 -- * Template - The annotation utilizes the generic template of the
13967 -- related subprogram [body] when it is:
13969 -- aspect on subprogram declaration
13970 -- aspect on stand-alone subprogram body
13971 -- pragma on stand-alone subprogram body
13973 -- The annotation must prepare its own template when it is:
13975 -- pragma on subprogram declaration
13977 -- * Globals - Capture of global references must occur after full
13980 -- * Instance - The annotation is instantiated automatically when
13981 -- the related generic subprogram [body] is instantiated except for
13982 -- the "pragma on subprogram declaration" case. In that scenario
13983 -- the annotation must instantiate itself.
13985 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13986 Spec_Id
: Entity_Id
;
13987 Subp_Decl
: Node_Id
;
13988 Subp_Spec
: Node_Id
;
13992 Check_No_Identifiers
;
13993 Check_Arg_Count
(1);
13995 -- Ensure the proper placement of the pragma. Contract_Cases must
13996 -- be associated with a subprogram declaration or a body that acts
14000 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14004 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14007 -- Generic subprogram
14009 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14012 -- Body acts as spec
14014 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14015 and then No
(Corresponding_Spec
(Subp_Decl
))
14019 -- Body stub acts as spec
14021 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14022 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14028 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14029 Subp_Spec
:= Specification
(Subp_Decl
);
14031 -- Pragma Contract_Cases is forbidden on null procedures, as
14032 -- this may lead to potential ambiguities in behavior when
14033 -- interface null procedures are involved.
14035 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14036 and then Null_Present
(Subp_Spec
)
14038 Error_Msg_N
(Fix_Error
14039 ("pragma % cannot apply to null procedure"), N
);
14048 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14050 -- A pragma that applies to a Ghost entity becomes Ghost for the
14051 -- purposes of legality checks and removal of ignored Ghost code.
14053 Mark_Ghost_Pragma
(N
, Spec_Id
);
14054 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14056 -- Chain the pragma on the contract for further processing by
14057 -- Analyze_Contract_Cases_In_Decl_Part.
14059 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14061 -- Fully analyze the pragma when it appears inside an entry
14062 -- or subprogram body because it cannot benefit from forward
14065 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14067 N_Subprogram_Body_Stub
)
14069 -- The legality checks of pragma Contract_Cases are affected by
14070 -- the SPARK mode in effect and the volatility of the context.
14071 -- Analyze all pragmas in a specific order.
14073 Analyze_If_Present
(Pragma_SPARK_Mode
);
14074 Analyze_If_Present
(Pragma_Volatile_Function
);
14075 Analyze_Contract_Cases_In_Decl_Part
(N
);
14077 end Contract_Cases
;
14083 -- pragma Controlled (first_subtype_LOCAL_NAME);
14085 when Pragma_Controlled
=> Controlled
: declare
14089 Check_No_Identifiers
;
14090 Check_Arg_Count
(1);
14091 Check_Arg_Is_Local_Name
(Arg1
);
14092 Arg
:= Get_Pragma_Arg
(Arg1
);
14094 if not Is_Entity_Name
(Arg
)
14095 or else not Is_Access_Type
(Entity
(Arg
))
14097 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14099 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14107 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14108 -- [Entity =>] LOCAL_NAME);
14110 when Pragma_Convention
=> Convention
: declare
14113 pragma Warnings
(Off
, C
);
14114 pragma Warnings
(Off
, E
);
14117 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14118 Check_Ada_83_Warning
;
14119 Check_Arg_Count
(2);
14120 Process_Convention
(C
, E
);
14122 -- A pragma that applies to a Ghost entity becomes Ghost for the
14123 -- purposes of legality checks and removal of ignored Ghost code.
14125 Mark_Ghost_Pragma
(N
, E
);
14128 ---------------------------
14129 -- Convention_Identifier --
14130 ---------------------------
14132 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14133 -- [Convention =>] convention_IDENTIFIER);
14135 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14141 Check_Arg_Order
((Name_Name
, Name_Convention
));
14142 Check_Arg_Count
(2);
14143 Check_Optional_Identifier
(Arg1
, Name_Name
);
14144 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14145 Check_Arg_Is_Identifier
(Arg1
);
14146 Check_Arg_Is_Identifier
(Arg2
);
14147 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14148 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14150 if Is_Convention_Name
(Cname
) then
14151 Record_Convention_Identifier
14152 (Idnam
, Get_Convention_Id
(Cname
));
14155 ("second arg for % pragma must be convention", Arg2
);
14157 end Convention_Identifier
;
14163 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14165 when Pragma_CPP_Class
=>
14168 if Warn_On_Obsolescent_Feature
then
14170 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14171 & "effect; replace it by pragma import?j?", N
);
14174 Check_Arg_Count
(1);
14178 Chars
=> Name_Import
,
14179 Pragma_Argument_Associations
=> New_List
(
14180 Make_Pragma_Argument_Association
(Loc
,
14181 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14182 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14185 ---------------------
14186 -- CPP_Constructor --
14187 ---------------------
14189 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14190 -- [, [External_Name =>] static_string_EXPRESSION ]
14191 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14193 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14196 Def_Id
: Entity_Id
;
14197 Tag_Typ
: Entity_Id
;
14201 Check_At_Least_N_Arguments
(1);
14202 Check_At_Most_N_Arguments
(3);
14203 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14204 Check_Arg_Is_Local_Name
(Arg1
);
14206 Id
:= Get_Pragma_Arg
(Arg1
);
14207 Find_Program_Unit_Name
(Id
);
14209 -- If we did not find the name, we are done
14211 if Etype
(Id
) = Any_Type
then
14215 Def_Id
:= Entity
(Id
);
14217 -- Check if already defined as constructor
14219 if Is_Constructor
(Def_Id
) then
14221 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14225 if Ekind
(Def_Id
) = E_Function
14226 and then (Is_CPP_Class
(Etype
(Def_Id
))
14227 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14229 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14231 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14233 ("'C'P'P constructor must be defined in the scope of "
14234 & "its returned type", Arg1
);
14237 if Arg_Count
>= 2 then
14238 Set_Imported
(Def_Id
);
14239 Set_Is_Public
(Def_Id
);
14240 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14243 Set_Has_Completion
(Def_Id
);
14244 Set_Is_Constructor
(Def_Id
);
14245 Set_Convention
(Def_Id
, Convention_CPP
);
14247 -- Imported C++ constructors are not dispatching primitives
14248 -- because in C++ they don't have a dispatch table slot.
14249 -- However, in Ada the constructor has the profile of a
14250 -- function that returns a tagged type and therefore it has
14251 -- been treated as a primitive operation during semantic
14252 -- analysis. We now remove it from the list of primitive
14253 -- operations of the type.
14255 if Is_Tagged_Type
(Etype
(Def_Id
))
14256 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14257 and then Is_Dispatching_Operation
(Def_Id
)
14259 Tag_Typ
:= Etype
(Def_Id
);
14261 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14262 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14266 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14267 Set_Is_Dispatching_Operation
(Def_Id
, False);
14270 -- For backward compatibility, if the constructor returns a
14271 -- class wide type, and we internally change the return type to
14272 -- the corresponding root type.
14274 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14275 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14279 ("pragma% requires function returning a 'C'P'P_Class type",
14282 end CPP_Constructor
;
14288 when Pragma_CPP_Virtual
=>
14291 if Warn_On_Obsolescent_Feature
then
14293 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14301 when Pragma_CPP_Vtable
=>
14304 if Warn_On_Obsolescent_Feature
then
14306 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14314 -- pragma CPU (EXPRESSION);
14316 when Pragma_CPU
=> CPU
: declare
14317 P
: constant Node_Id
:= Parent
(N
);
14323 Check_No_Identifiers
;
14324 Check_Arg_Count
(1);
14328 if Nkind
(P
) = N_Subprogram_Body
then
14329 Check_In_Main_Program
;
14331 Arg
:= Get_Pragma_Arg
(Arg1
);
14332 Analyze_And_Resolve
(Arg
, Any_Integer
);
14334 Ent
:= Defining_Unit_Name
(Specification
(P
));
14336 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
14337 Ent
:= Defining_Identifier
(Ent
);
14342 if not Is_OK_Static_Expression
(Arg
) then
14343 Flag_Non_Static_Expr
14344 ("main subprogram affinity is not static!", Arg
);
14347 -- If constraint error, then we already signalled an error
14349 elsif Raises_Constraint_Error
(Arg
) then
14352 -- Otherwise check in range
14356 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
14357 -- This is the entity System.Multiprocessors.CPU_Range;
14359 Val
: constant Uint
:= Expr_Value
(Arg
);
14362 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
14364 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
14367 ("main subprogram CPU is out of range", Arg1
);
14373 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
14377 elsif Nkind
(P
) = N_Task_Definition
then
14378 Arg
:= Get_Pragma_Arg
(Arg1
);
14379 Ent
:= Defining_Identifier
(Parent
(P
));
14381 -- The expression must be analyzed in the special manner
14382 -- described in "Handling of Default and Per-Object
14383 -- Expressions" in sem.ads.
14385 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
14387 -- Anything else is incorrect
14393 -- Check duplicate pragma before we chain the pragma in the Rep
14394 -- Item chain of Ent.
14396 Check_Duplicate_Pragma
(Ent
);
14397 Record_Rep_Item
(Ent
, N
);
14400 --------------------
14401 -- Deadline_Floor --
14402 --------------------
14404 -- pragma Deadline_Floor (time_span_EXPRESSION);
14406 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
14407 P
: constant Node_Id
:= Parent
(N
);
14413 Check_No_Identifiers
;
14414 Check_Arg_Count
(1);
14416 Arg
:= Get_Pragma_Arg
(Arg1
);
14418 -- The expression must be analyzed in the special manner described
14419 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14421 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
14423 -- Only protected types allowed
14425 if Nkind
(P
) /= N_Protected_Definition
then
14429 Ent
:= Defining_Identifier
(Parent
(P
));
14431 -- Check duplicate pragma before we chain the pragma in the Rep
14432 -- Item chain of Ent.
14434 Check_Duplicate_Pragma
(Ent
);
14435 Record_Rep_Item
(Ent
, N
);
14437 end Deadline_Floor
;
14443 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14445 when Pragma_Debug
=> Debug
: declare
14452 -- The condition for executing the call is that the expander
14453 -- is active and that we are not ignoring this debug pragma.
14458 (Expander_Active
and then not Is_Ignored
(N
)),
14461 if not Is_Ignored
(N
) then
14462 Set_SCO_Pragma_Enabled
(Loc
);
14465 if Arg_Count
= 2 then
14467 Make_And_Then
(Loc
,
14468 Left_Opnd
=> Relocate_Node
(Cond
),
14469 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
14470 Call
:= Get_Pragma_Arg
(Arg2
);
14472 Call
:= Get_Pragma_Arg
(Arg1
);
14475 if Nkind_In
(Call
, N_Expanded_Name
,
14478 N_Indexed_Component
,
14479 N_Selected_Component
)
14481 -- If this pragma Debug comes from source, its argument was
14482 -- parsed as a name form (which is syntactically identical).
14483 -- In a generic context a parameterless call will be left as
14484 -- an expanded name (if global) or selected_component if local.
14485 -- Change it to a procedure call statement now.
14487 Change_Name_To_Procedure_Call_Statement
(Call
);
14489 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
14491 -- Already in the form of a procedure call statement: nothing
14492 -- to do (could happen in case of an internally generated
14498 -- All other cases: diagnose error
14501 ("argument of pragma ""Debug"" is not procedure call",
14506 -- Rewrite into a conditional with an appropriate condition. We
14507 -- wrap the procedure call in a block so that overhead from e.g.
14508 -- use of the secondary stack does not generate execution overhead
14509 -- for suppressed conditions.
14511 -- Normally the analysis that follows will freeze the subprogram
14512 -- being called. However, if the call is to a null procedure,
14513 -- we want to freeze it before creating the block, because the
14514 -- analysis that follows may be done with expansion disabled, in
14515 -- which case the body will not be generated, leading to spurious
14518 if Nkind
(Call
) = N_Procedure_Call_Statement
14519 and then Is_Entity_Name
(Name
(Call
))
14521 Analyze
(Name
(Call
));
14522 Freeze_Before
(N
, Entity
(Name
(Call
)));
14526 Make_Implicit_If_Statement
(N
,
14528 Then_Statements
=> New_List
(
14529 Make_Block_Statement
(Loc
,
14530 Handled_Statement_Sequence
=>
14531 Make_Handled_Sequence_Of_Statements
(Loc
,
14532 Statements
=> New_List
(Relocate_Node
(Call
)))))));
14535 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14536 -- after analysis of the normally rewritten node, to capture all
14537 -- references to entities, which avoids issuing wrong warnings
14538 -- about unused entities.
14540 if GNATprove_Mode
then
14541 Rewrite
(N
, Make_Null_Statement
(Loc
));
14549 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14551 when Pragma_Debug_Policy
=>
14553 Check_Arg_Count
(1);
14554 Check_No_Identifiers
;
14555 Check_Arg_Is_Identifier
(Arg1
);
14557 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14558 -- rewrite it that way, and let the rest of the checking come
14559 -- from analyzing the rewritten pragma.
14563 Chars
=> Name_Check_Policy
,
14564 Pragma_Argument_Associations
=> New_List
(
14565 Make_Pragma_Argument_Association
(Loc
,
14566 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14568 Make_Pragma_Argument_Association
(Loc
,
14569 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14572 -------------------------------
14573 -- Default_Initial_Condition --
14574 -------------------------------
14576 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14578 when Pragma_Default_Initial_Condition
=> DIC
: declare
14585 Check_No_Identifiers
;
14586 Check_At_Most_N_Arguments
(1);
14590 while Present
(Stmt
) loop
14592 -- Skip prior pragmas, but check for duplicates
14594 if Nkind
(Stmt
) = N_Pragma
then
14595 if Pragma_Name
(Stmt
) = Pname
then
14602 -- Skip internally generated code. Note that derived type
14603 -- declarations of untagged types with discriminants are
14604 -- rewritten as private type declarations.
14606 elsif not Comes_From_Source
(Stmt
)
14607 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14611 -- The associated private type [extension] has been found, stop
14614 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14615 N_Private_Type_Declaration
)
14617 Typ
:= Defining_Entity
(Stmt
);
14620 -- The pragma does not apply to a legal construct, issue an
14621 -- error and stop the analysis.
14628 Stmt
:= Prev
(Stmt
);
14631 -- The pragma does not apply to a legal construct, issue an error
14632 -- and stop the analysis.
14639 -- A pragma that applies to a Ghost entity becomes Ghost for the
14640 -- purposes of legality checks and removal of ignored Ghost code.
14642 Mark_Ghost_Pragma
(N
, Typ
);
14644 -- The pragma signals that the type defines its own DIC assertion
14647 Set_Has_Own_DIC
(Typ
);
14649 -- Chain the pragma on the rep item chain for further processing
14651 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14653 -- Create the declaration of the procedure which verifies the
14654 -- assertion expression of pragma DIC at runtime.
14656 Build_DIC_Procedure_Declaration
(Typ
);
14659 ----------------------------------
14660 -- Default_Scalar_Storage_Order --
14661 ----------------------------------
14663 -- pragma Default_Scalar_Storage_Order
14664 -- (High_Order_First | Low_Order_First);
14666 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14667 Default
: Character;
14671 Check_Arg_Count
(1);
14673 -- Default_Scalar_Storage_Order can appear as a configuration
14674 -- pragma, or in a declarative part of a package spec.
14676 if not Is_Configuration_Pragma
then
14677 Check_Is_In_Decl_Part_Or_Package_Spec
;
14680 Check_No_Identifiers
;
14681 Check_Arg_Is_One_Of
14682 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14683 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14684 Default
:= Fold_Upper
(Name_Buffer
(1));
14686 if not Support_Nondefault_SSO_On_Target
14687 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14689 if Warn_On_Unrecognized_Pragma
then
14691 ("non-default Scalar_Storage_Order not supported "
14692 & "on target?g?", N
);
14694 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14697 -- Here set the specified default
14700 Opt
.Default_SSO
:= Default
;
14704 --------------------------
14705 -- Default_Storage_Pool --
14706 --------------------------
14708 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14710 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14715 Check_Arg_Count
(1);
14717 -- Default_Storage_Pool can appear as a configuration pragma, or
14718 -- in a declarative part of a package spec.
14720 if not Is_Configuration_Pragma
then
14721 Check_Is_In_Decl_Part_Or_Package_Spec
;
14724 if From_Aspect_Specification
(N
) then
14726 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14728 if not In_Open_Scopes
(E
) then
14730 ("aspect must apply to package or subprogram", N
);
14735 if Present
(Arg1
) then
14736 Pool
:= Get_Pragma_Arg
(Arg1
);
14738 -- Case of Default_Storage_Pool (null);
14740 if Nkind
(Pool
) = N_Null
then
14743 -- This is an odd case, this is not really an expression,
14744 -- so we don't have a type for it. So just set the type to
14747 Set_Etype
(Pool
, Empty
);
14749 -- Case of Default_Storage_Pool (storage_pool_NAME);
14752 -- If it's a configuration pragma, then the only allowed
14753 -- argument is "null".
14755 if Is_Configuration_Pragma
then
14756 Error_Pragma_Arg
("NULL expected", Arg1
);
14759 -- The expected type for a non-"null" argument is
14760 -- Root_Storage_Pool'Class, and the pool must be a variable.
14762 Analyze_And_Resolve
14763 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14765 if Is_Variable
(Pool
) then
14767 -- A pragma that applies to a Ghost entity becomes Ghost
14768 -- for the purposes of legality checks and removal of
14769 -- ignored Ghost code.
14771 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14775 ("default storage pool must be a variable", Arg1
);
14779 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14780 -- access type will use this information to set the appropriate
14781 -- attributes of the access type. If the pragma appears in a
14782 -- generic unit it is ignored, given that it may refer to a
14785 if not Inside_A_Generic
then
14786 Default_Pool
:= Pool
;
14789 end Default_Storage_Pool
;
14795 -- pragma Depends (DEPENDENCY_RELATION);
14797 -- DEPENDENCY_RELATION ::=
14799 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14801 -- DEPENDENCY_CLAUSE ::=
14802 -- OUTPUT_LIST =>[+] INPUT_LIST
14803 -- | NULL_DEPENDENCY_CLAUSE
14805 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14807 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14809 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14811 -- OUTPUT ::= NAME | FUNCTION_RESULT
14814 -- where FUNCTION_RESULT is a function Result attribute_reference
14816 -- Characteristics:
14818 -- * Analysis - The annotation undergoes initial checks to verify
14819 -- the legal placement and context. Secondary checks fully analyze
14820 -- the dependency clauses in:
14822 -- Analyze_Depends_In_Decl_Part
14824 -- * Expansion - None.
14826 -- * Template - The annotation utilizes the generic template of the
14827 -- related subprogram [body] when it is:
14829 -- aspect on subprogram declaration
14830 -- aspect on stand-alone subprogram body
14831 -- pragma on stand-alone subprogram body
14833 -- The annotation must prepare its own template when it is:
14835 -- pragma on subprogram declaration
14837 -- * Globals - Capture of global references must occur after full
14840 -- * Instance - The annotation is instantiated automatically when
14841 -- the related generic subprogram [body] is instantiated except for
14842 -- the "pragma on subprogram declaration" case. In that scenario
14843 -- the annotation must instantiate itself.
14845 when Pragma_Depends
=> Depends
: declare
14847 Spec_Id
: Entity_Id
;
14848 Subp_Decl
: Node_Id
;
14851 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14855 -- Chain the pragma on the contract for further processing by
14856 -- Analyze_Depends_In_Decl_Part.
14858 Add_Contract_Item
(N
, Spec_Id
);
14860 -- Fully analyze the pragma when it appears inside an entry
14861 -- or subprogram body because it cannot benefit from forward
14864 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14866 N_Subprogram_Body_Stub
)
14868 -- The legality checks of pragmas Depends and Global are
14869 -- affected by the SPARK mode in effect and the volatility
14870 -- of the context. In addition these two pragmas are subject
14871 -- to an inherent order:
14876 -- Analyze all these pragmas in the order outlined above
14878 Analyze_If_Present
(Pragma_SPARK_Mode
);
14879 Analyze_If_Present
(Pragma_Volatile_Function
);
14880 Analyze_If_Present
(Pragma_Global
);
14881 Analyze_Depends_In_Decl_Part
(N
);
14886 ---------------------
14887 -- Detect_Blocking --
14888 ---------------------
14890 -- pragma Detect_Blocking;
14892 when Pragma_Detect_Blocking
=>
14894 Check_Arg_Count
(0);
14895 Check_Valid_Configuration_Pragma
;
14896 Detect_Blocking
:= True;
14898 ------------------------------------
14899 -- Disable_Atomic_Synchronization --
14900 ------------------------------------
14902 -- pragma Disable_Atomic_Synchronization [(Entity)];
14904 when Pragma_Disable_Atomic_Synchronization
=>
14906 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14908 -------------------
14909 -- Discard_Names --
14910 -------------------
14912 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14914 when Pragma_Discard_Names
=> Discard_Names
: declare
14919 Check_Ada_83_Warning
;
14921 -- Deal with configuration pragma case
14923 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14924 Global_Discard_Names
:= True;
14927 -- Otherwise, check correct appropriate context
14930 Check_Is_In_Decl_Part_Or_Package_Spec
;
14932 if Arg_Count
= 0 then
14934 -- If there is no parameter, then from now on this pragma
14935 -- applies to any enumeration, exception or tagged type
14936 -- defined in the current declarative part, and recursively
14937 -- to any nested scope.
14939 Set_Discard_Names
(Current_Scope
);
14943 Check_Arg_Count
(1);
14944 Check_Optional_Identifier
(Arg1
, Name_On
);
14945 Check_Arg_Is_Local_Name
(Arg1
);
14947 E_Id
:= Get_Pragma_Arg
(Arg1
);
14949 if Etype
(E_Id
) = Any_Type
then
14953 E
:= Entity
(E_Id
);
14955 -- A pragma that applies to a Ghost entity becomes Ghost for
14956 -- the purposes of legality checks and removal of ignored
14959 Mark_Ghost_Pragma
(N
, E
);
14961 if (Is_First_Subtype
(E
)
14963 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14964 or else Ekind
(E
) = E_Exception
14966 Set_Discard_Names
(E
);
14967 Record_Rep_Item
(E
, N
);
14971 ("inappropriate entity for pragma%", Arg1
);
14977 ------------------------
14978 -- Dispatching_Domain --
14979 ------------------------
14981 -- pragma Dispatching_Domain (EXPRESSION);
14983 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14984 P
: constant Node_Id
:= Parent
(N
);
14990 Check_No_Identifiers
;
14991 Check_Arg_Count
(1);
14993 -- This pragma is born obsolete, but not the aspect
14995 if not From_Aspect_Specification
(N
) then
14997 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15000 if Nkind
(P
) = N_Task_Definition
then
15001 Arg
:= Get_Pragma_Arg
(Arg1
);
15002 Ent
:= Defining_Identifier
(Parent
(P
));
15004 -- A pragma that applies to a Ghost entity becomes Ghost for
15005 -- the purposes of legality checks and removal of ignored Ghost
15008 Mark_Ghost_Pragma
(N
, Ent
);
15010 -- The expression must be analyzed in the special manner
15011 -- described in "Handling of Default and Per-Object
15012 -- Expressions" in sem.ads.
15014 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15016 -- Check duplicate pragma before we chain the pragma in the Rep
15017 -- Item chain of Ent.
15019 Check_Duplicate_Pragma
(Ent
);
15020 Record_Rep_Item
(Ent
, N
);
15022 -- Anything else is incorrect
15027 end Dispatching_Domain
;
15033 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15035 when Pragma_Elaborate
=> Elaborate
: declare
15040 -- Pragma must be in context items list of a compilation unit
15042 if not Is_In_Context_Clause
then
15046 -- Must be at least one argument
15048 if Arg_Count
= 0 then
15049 Error_Pragma
("pragma% requires at least one argument");
15052 -- In Ada 83 mode, there can be no items following it in the
15053 -- context list except other pragmas and implicit with clauses
15054 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15055 -- placement rule does not apply.
15057 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15059 while Present
(Citem
) loop
15060 if Nkind
(Citem
) = N_Pragma
15061 or else (Nkind
(Citem
) = N_With_Clause
15062 and then Implicit_With
(Citem
))
15067 ("(Ada 83) pragma% must be at end of context clause");
15074 -- Finally, the arguments must all be units mentioned in a with
15075 -- clause in the same context clause. Note we already checked (in
15076 -- Par.Prag) that the arguments are all identifiers or selected
15080 Outer
: while Present
(Arg
) loop
15081 Citem
:= First
(List_Containing
(N
));
15082 Inner
: while Citem
/= N
loop
15083 if Nkind
(Citem
) = N_With_Clause
15084 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15086 Set_Elaborate_Present
(Citem
, True);
15087 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15089 -- With the pragma present, elaboration calls on
15090 -- subprograms from the named unit need no further
15091 -- checks, as long as the pragma appears in the current
15092 -- compilation unit. If the pragma appears in some unit
15093 -- in the context, there might still be a need for an
15094 -- Elaborate_All_Desirable from the current compilation
15095 -- to the named unit, so we keep the check enabled. This
15096 -- does not apply in SPARK mode, where we allow pragma
15097 -- Elaborate, but we don't trust it to be right so we
15098 -- will still insist on the Elaborate_All.
15100 if Legacy_Elaboration_Checks
15101 and then In_Extended_Main_Source_Unit
(N
)
15102 and then SPARK_Mode
/= On
15104 Set_Suppress_Elaboration_Warnings
15105 (Entity
(Name
(Citem
)));
15116 ("argument of pragma% is not withed unit", Arg
);
15123 -------------------
15124 -- Elaborate_All --
15125 -------------------
15127 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15129 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15134 Check_Ada_83_Warning
;
15136 -- Pragma must be in context items list of a compilation unit
15138 if not Is_In_Context_Clause
then
15142 -- Must be at least one argument
15144 if Arg_Count
= 0 then
15145 Error_Pragma
("pragma% requires at least one argument");
15148 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15149 -- have to appear at the end of the context clause, but may
15150 -- appear mixed in with other items, even in Ada 83 mode.
15152 -- Final check: the arguments must all be units mentioned in
15153 -- a with clause in the same context clause. Note that we
15154 -- already checked (in Par.Prag) that all the arguments are
15155 -- either identifiers or selected components.
15158 Outr
: while Present
(Arg
) loop
15159 Citem
:= First
(List_Containing
(N
));
15160 Innr
: while Citem
/= N
loop
15161 if Nkind
(Citem
) = N_With_Clause
15162 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15164 Set_Elaborate_All_Present
(Citem
, True);
15165 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15167 -- Suppress warnings and elaboration checks on the named
15168 -- unit if the pragma is in the current compilation, as
15169 -- for pragma Elaborate.
15171 if Legacy_Elaboration_Checks
15172 and then In_Extended_Main_Source_Unit
(N
)
15174 Set_Suppress_Elaboration_Warnings
15175 (Entity
(Name
(Citem
)));
15185 Set_Error_Posted
(N
);
15187 ("argument of pragma% is not withed unit", Arg
);
15194 --------------------
15195 -- Elaborate_Body --
15196 --------------------
15198 -- pragma Elaborate_Body [( library_unit_NAME )];
15200 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15201 Cunit_Node
: Node_Id
;
15202 Cunit_Ent
: Entity_Id
;
15205 Check_Ada_83_Warning
;
15206 Check_Valid_Library_Unit_Pragma
;
15208 if Nkind
(N
) = N_Null_Statement
then
15212 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15213 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15215 -- A pragma that applies to a Ghost entity becomes Ghost for the
15216 -- purposes of legality checks and removal of ignored Ghost code.
15218 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15220 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15223 Error_Pragma
("pragma% must refer to a spec, not a body");
15225 Set_Body_Required
(Cunit_Node
);
15226 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15228 -- If we are in dynamic elaboration mode, then we suppress
15229 -- elaboration warnings for the unit, since it is definitely
15230 -- fine NOT to do dynamic checks at the first level (and such
15231 -- checks will be suppressed because no elaboration boolean
15232 -- is created for Elaborate_Body packages).
15234 -- But in the static model of elaboration, Elaborate_Body is
15235 -- definitely NOT good enough to ensure elaboration safety on
15236 -- its own, since the body may WITH other units that are not
15237 -- safe from an elaboration point of view, so a client must
15238 -- still do an Elaborate_All on such units.
15240 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15241 -- Elaborate_Body always suppressed elab warnings.
15243 if Legacy_Elaboration_Checks
15244 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15246 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15249 end Elaborate_Body
;
15251 ------------------------
15252 -- Elaboration_Checks --
15253 ------------------------
15255 -- pragma Elaboration_Checks (Static | Dynamic);
15257 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
15258 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
15259 -- Emit an error if the current context list already contains
15260 -- a previous Elaboration_Checks pragma. This routine raises
15261 -- Pragma_Exit if a duplicate is found.
15263 procedure Ignore_Elaboration_Checks_Pragma
;
15264 -- Warn that the effects of the pragma are ignored. This routine
15265 -- raises Pragma_Exit.
15267 -----------------------------------------------
15268 -- Check_Duplicate_Elaboration_Checks_Pragma --
15269 -----------------------------------------------
15271 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
15276 while Present
(Item
) loop
15277 if Nkind
(Item
) = N_Pragma
15278 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
15288 end Check_Duplicate_Elaboration_Checks_Pragma
;
15290 --------------------------------------
15291 -- Ignore_Elaboration_Checks_Pragma --
15292 --------------------------------------
15294 procedure Ignore_Elaboration_Checks_Pragma
is
15296 Error_Msg_Name_1
:= Pname
;
15297 Error_Msg_N
("??effects of pragma % are ignored", N
);
15299 ("\place pragma on initial declaration of library unit", N
);
15302 end Ignore_Elaboration_Checks_Pragma
;
15306 Context
: constant Node_Id
:= Parent
(N
);
15309 -- Start of processing for Elaboration_Checks
15313 Check_Arg_Count
(1);
15314 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
15316 -- The pragma appears in a configuration file
15318 if No
(Context
) then
15319 Check_Valid_Configuration_Pragma
;
15320 Check_Duplicate_Elaboration_Checks_Pragma
;
15322 -- The pragma acts as a configuration pragma in a compilation unit
15324 -- pragma Elaboration_Checks (...);
15325 -- package Pack is ...;
15327 elsif Nkind
(Context
) = N_Compilation_Unit
15328 and then List_Containing
(N
) = Context_Items
(Context
)
15330 Check_Valid_Configuration_Pragma
;
15331 Check_Duplicate_Elaboration_Checks_Pragma
;
15333 Unt
:= Unit
(Context
);
15335 -- The pragma must appear on the initial declaration of a unit.
15336 -- If this is not the case, warn that the effects of the pragma
15339 if Nkind
(Unt
) = N_Package_Body
then
15340 Ignore_Elaboration_Checks_Pragma
;
15342 -- Check the Acts_As_Spec flag of the compilation units itself
15343 -- to determine whether the subprogram body completes since it
15344 -- has not been analyzed yet. This is safe because compilation
15345 -- units are not overloadable.
15347 elsif Nkind
(Unt
) = N_Subprogram_Body
15348 and then not Acts_As_Spec
(Context
)
15350 Ignore_Elaboration_Checks_Pragma
;
15352 elsif Nkind
(Unt
) = N_Subunit
then
15353 Ignore_Elaboration_Checks_Pragma
;
15356 -- Otherwise the pragma does not appear at the configuration level
15363 -- At this point the pragma is not a duplicate, and appears in the
15364 -- proper context. Set the elaboration model in effect.
15366 Dynamic_Elaboration_Checks
:=
15367 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
15368 end Elaboration_Checks
;
15374 -- pragma Eliminate (
15375 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15376 -- [Entity =>] IDENTIFIER |
15377 -- SELECTED_COMPONENT |
15379 -- [, Source_Location => SOURCE_TRACE]);
15381 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15382 -- SOURCE_TRACE ::= STRING_LITERAL
15384 when Pragma_Eliminate
=> Eliminate
: declare
15385 Args
: Args_List
(1 .. 5);
15386 Names
: constant Name_List
(1 .. 5) := (
15389 Name_Parameter_Types
,
15391 Name_Source_Location
);
15393 -- Note : Parameter_Types and Result_Type are leftovers from
15394 -- prior implementations of the pragma. They are not generated
15395 -- by the gnatelim tool, and play no role in selecting which
15396 -- of a set of overloaded names is chosen for elimination.
15398 Unit_Name
: Node_Id
renames Args
(1);
15399 Entity
: Node_Id
renames Args
(2);
15400 Parameter_Types
: Node_Id
renames Args
(3);
15401 Result_Type
: Node_Id
renames Args
(4);
15402 Source_Location
: Node_Id
renames Args
(5);
15406 Check_Valid_Configuration_Pragma
;
15407 Gather_Associations
(Names
, Args
);
15409 if No
(Unit_Name
) then
15410 Error_Pragma
("missing Unit_Name argument for pragma%");
15414 and then (Present
(Parameter_Types
)
15416 Present
(Result_Type
)
15418 Present
(Source_Location
))
15420 Error_Pragma
("missing Entity argument for pragma%");
15423 if (Present
(Parameter_Types
)
15425 Present
(Result_Type
))
15427 Present
(Source_Location
)
15430 ("parameter profile and source location cannot be used "
15431 & "together in pragma%");
15434 Process_Eliminate_Pragma
15443 -----------------------------------
15444 -- Enable_Atomic_Synchronization --
15445 -----------------------------------
15447 -- pragma Enable_Atomic_Synchronization [(Entity)];
15449 when Pragma_Enable_Atomic_Synchronization
=>
15451 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
15458 -- [ Convention =>] convention_IDENTIFIER,
15459 -- [ Entity =>] LOCAL_NAME
15460 -- [, [External_Name =>] static_string_EXPRESSION ]
15461 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15463 when Pragma_Export
=> Export
: declare
15465 Def_Id
: Entity_Id
;
15467 pragma Warnings
(Off
, C
);
15470 Check_Ada_83_Warning
;
15474 Name_External_Name
,
15477 Check_At_Least_N_Arguments
(2);
15478 Check_At_Most_N_Arguments
(4);
15480 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15481 -- pragma Export (Entity, "external name");
15483 if Relaxed_RM_Semantics
15484 and then Arg_Count
= 2
15485 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
15488 Def_Id
:= Get_Pragma_Arg
(Arg1
);
15491 if not Is_Entity_Name
(Def_Id
) then
15492 Error_Pragma_Arg
("entity name required", Arg1
);
15495 Def_Id
:= Entity
(Def_Id
);
15496 Set_Exported
(Def_Id
, Arg1
);
15499 Process_Convention
(C
, Def_Id
);
15501 -- A pragma that applies to a Ghost entity becomes Ghost for
15502 -- the purposes of legality checks and removal of ignored Ghost
15505 Mark_Ghost_Pragma
(N
, Def_Id
);
15507 if Ekind
(Def_Id
) /= E_Constant
then
15508 Note_Possible_Modification
15509 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15512 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
15513 Set_Exported
(Def_Id
, Arg2
);
15516 -- If the entity is a deferred constant, propagate the information
15517 -- to the full view, because gigi elaborates the full view only.
15519 if Ekind
(Def_Id
) = E_Constant
15520 and then Present
(Full_View
(Def_Id
))
15523 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
15525 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
15526 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
15527 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
15532 ---------------------
15533 -- Export_Function --
15534 ---------------------
15536 -- pragma Export_Function (
15537 -- [Internal =>] LOCAL_NAME
15538 -- [, [External =>] EXTERNAL_SYMBOL]
15539 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15540 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15541 -- [, [Mechanism =>] MECHANISM]
15542 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15544 -- EXTERNAL_SYMBOL ::=
15546 -- | static_string_EXPRESSION
15548 -- PARAMETER_TYPES ::=
15550 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15552 -- TYPE_DESIGNATOR ::=
15554 -- | subtype_Name ' Access
15558 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15560 -- MECHANISM_ASSOCIATION ::=
15561 -- [formal_parameter_NAME =>] MECHANISM_NAME
15563 -- MECHANISM_NAME ::=
15567 when Pragma_Export_Function
=> Export_Function
: declare
15568 Args
: Args_List
(1 .. 6);
15569 Names
: constant Name_List
(1 .. 6) := (
15572 Name_Parameter_Types
,
15575 Name_Result_Mechanism
);
15577 Internal
: Node_Id
renames Args
(1);
15578 External
: Node_Id
renames Args
(2);
15579 Parameter_Types
: Node_Id
renames Args
(3);
15580 Result_Type
: Node_Id
renames Args
(4);
15581 Mechanism
: Node_Id
renames Args
(5);
15582 Result_Mechanism
: Node_Id
renames Args
(6);
15586 Gather_Associations
(Names
, Args
);
15587 Process_Extended_Import_Export_Subprogram_Pragma
(
15588 Arg_Internal
=> Internal
,
15589 Arg_External
=> External
,
15590 Arg_Parameter_Types
=> Parameter_Types
,
15591 Arg_Result_Type
=> Result_Type
,
15592 Arg_Mechanism
=> Mechanism
,
15593 Arg_Result_Mechanism
=> Result_Mechanism
);
15594 end Export_Function
;
15596 -------------------
15597 -- Export_Object --
15598 -------------------
15600 -- pragma Export_Object (
15601 -- [Internal =>] LOCAL_NAME
15602 -- [, [External =>] EXTERNAL_SYMBOL]
15603 -- [, [Size =>] EXTERNAL_SYMBOL]);
15605 -- EXTERNAL_SYMBOL ::=
15607 -- | static_string_EXPRESSION
15609 -- PARAMETER_TYPES ::=
15611 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15613 -- TYPE_DESIGNATOR ::=
15615 -- | subtype_Name ' Access
15619 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15621 -- MECHANISM_ASSOCIATION ::=
15622 -- [formal_parameter_NAME =>] MECHANISM_NAME
15624 -- MECHANISM_NAME ::=
15628 when Pragma_Export_Object
=> Export_Object
: declare
15629 Args
: Args_List
(1 .. 3);
15630 Names
: constant Name_List
(1 .. 3) := (
15635 Internal
: Node_Id
renames Args
(1);
15636 External
: Node_Id
renames Args
(2);
15637 Size
: Node_Id
renames Args
(3);
15641 Gather_Associations
(Names
, Args
);
15642 Process_Extended_Import_Export_Object_Pragma
(
15643 Arg_Internal
=> Internal
,
15644 Arg_External
=> External
,
15648 ----------------------
15649 -- Export_Procedure --
15650 ----------------------
15652 -- pragma Export_Procedure (
15653 -- [Internal =>] LOCAL_NAME
15654 -- [, [External =>] EXTERNAL_SYMBOL]
15655 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15656 -- [, [Mechanism =>] MECHANISM]);
15658 -- EXTERNAL_SYMBOL ::=
15660 -- | static_string_EXPRESSION
15662 -- PARAMETER_TYPES ::=
15664 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15666 -- TYPE_DESIGNATOR ::=
15668 -- | subtype_Name ' Access
15672 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15674 -- MECHANISM_ASSOCIATION ::=
15675 -- [formal_parameter_NAME =>] MECHANISM_NAME
15677 -- MECHANISM_NAME ::=
15681 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15682 Args
: Args_List
(1 .. 4);
15683 Names
: constant Name_List
(1 .. 4) := (
15686 Name_Parameter_Types
,
15689 Internal
: Node_Id
renames Args
(1);
15690 External
: Node_Id
renames Args
(2);
15691 Parameter_Types
: Node_Id
renames Args
(3);
15692 Mechanism
: Node_Id
renames Args
(4);
15696 Gather_Associations
(Names
, Args
);
15697 Process_Extended_Import_Export_Subprogram_Pragma
(
15698 Arg_Internal
=> Internal
,
15699 Arg_External
=> External
,
15700 Arg_Parameter_Types
=> Parameter_Types
,
15701 Arg_Mechanism
=> Mechanism
);
15702 end Export_Procedure
;
15708 -- pragma Export_Value (
15709 -- [Value =>] static_integer_EXPRESSION,
15710 -- [Link_Name =>] static_string_EXPRESSION);
15712 when Pragma_Export_Value
=>
15714 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15715 Check_Arg_Count
(2);
15717 Check_Optional_Identifier
(Arg1
, Name_Value
);
15718 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15720 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15721 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15723 -----------------------------
15724 -- Export_Valued_Procedure --
15725 -----------------------------
15727 -- pragma Export_Valued_Procedure (
15728 -- [Internal =>] LOCAL_NAME
15729 -- [, [External =>] EXTERNAL_SYMBOL,]
15730 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15731 -- [, [Mechanism =>] MECHANISM]);
15733 -- EXTERNAL_SYMBOL ::=
15735 -- | static_string_EXPRESSION
15737 -- PARAMETER_TYPES ::=
15739 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15741 -- TYPE_DESIGNATOR ::=
15743 -- | subtype_Name ' Access
15747 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15749 -- MECHANISM_ASSOCIATION ::=
15750 -- [formal_parameter_NAME =>] MECHANISM_NAME
15752 -- MECHANISM_NAME ::=
15756 when Pragma_Export_Valued_Procedure
=>
15757 Export_Valued_Procedure
: declare
15758 Args
: Args_List
(1 .. 4);
15759 Names
: constant Name_List
(1 .. 4) := (
15762 Name_Parameter_Types
,
15765 Internal
: Node_Id
renames Args
(1);
15766 External
: Node_Id
renames Args
(2);
15767 Parameter_Types
: Node_Id
renames Args
(3);
15768 Mechanism
: Node_Id
renames Args
(4);
15772 Gather_Associations
(Names
, Args
);
15773 Process_Extended_Import_Export_Subprogram_Pragma
(
15774 Arg_Internal
=> Internal
,
15775 Arg_External
=> External
,
15776 Arg_Parameter_Types
=> Parameter_Types
,
15777 Arg_Mechanism
=> Mechanism
);
15778 end Export_Valued_Procedure
;
15780 -------------------
15781 -- Extend_System --
15782 -------------------
15784 -- pragma Extend_System ([Name =>] Identifier);
15786 when Pragma_Extend_System
=>
15788 Check_Valid_Configuration_Pragma
;
15789 Check_Arg_Count
(1);
15790 Check_Optional_Identifier
(Arg1
, Name_Name
);
15791 Check_Arg_Is_Identifier
(Arg1
);
15793 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15796 and then Name_Buffer
(1 .. 4) = "aux_"
15798 if Present
(System_Extend_Pragma_Arg
) then
15799 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15800 Chars
(Expression
(System_Extend_Pragma_Arg
))
15804 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15805 Error_Pragma
("pragma% conflicts with that #");
15809 System_Extend_Pragma_Arg
:= Arg1
;
15811 if not GNAT_Mode
then
15812 System_Extend_Unit
:= Arg1
;
15816 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15819 ------------------------
15820 -- Extensions_Allowed --
15821 ------------------------
15823 -- pragma Extensions_Allowed (ON | OFF);
15825 when Pragma_Extensions_Allowed
=>
15827 Check_Arg_Count
(1);
15828 Check_No_Identifiers
;
15829 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15831 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15832 Extensions_Allowed
:= True;
15833 Ada_Version
:= Ada_Version_Type
'Last;
15836 Extensions_Allowed
:= False;
15837 Ada_Version
:= Ada_Version_Explicit
;
15838 Ada_Version_Pragma
:= Empty
;
15841 ------------------------
15842 -- Extensions_Visible --
15843 ------------------------
15845 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15847 -- Characteristics:
15849 -- * Analysis - The annotation is fully analyzed immediately upon
15850 -- elaboration as its expression must be static.
15852 -- * Expansion - None.
15854 -- * Template - The annotation utilizes the generic template of the
15855 -- related subprogram [body] when it is:
15857 -- aspect on subprogram declaration
15858 -- aspect on stand-alone subprogram body
15859 -- pragma on stand-alone subprogram body
15861 -- The annotation must prepare its own template when it is:
15863 -- pragma on subprogram declaration
15865 -- * Globals - Capture of global references must occur after full
15868 -- * Instance - The annotation is instantiated automatically when
15869 -- the related generic subprogram [body] is instantiated except for
15870 -- the "pragma on subprogram declaration" case. In that scenario
15871 -- the annotation must instantiate itself.
15873 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15874 Formal
: Entity_Id
;
15875 Has_OK_Formal
: Boolean := False;
15876 Spec_Id
: Entity_Id
;
15877 Subp_Decl
: Node_Id
;
15881 Check_No_Identifiers
;
15882 Check_At_Most_N_Arguments
(1);
15885 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15887 -- Abstract subprogram declaration
15889 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15892 -- Generic subprogram declaration
15894 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15897 -- Body acts as spec
15899 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15900 and then No
(Corresponding_Spec
(Subp_Decl
))
15904 -- Body stub acts as spec
15906 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15907 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15911 -- Subprogram declaration
15913 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15916 -- Otherwise the pragma is associated with an illegal construct
15919 Error_Pragma
("pragma % must apply to a subprogram");
15923 -- Mark the pragma as Ghost if the related subprogram is also
15924 -- Ghost. This also ensures that any expansion performed further
15925 -- below will produce Ghost nodes.
15927 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15928 Mark_Ghost_Pragma
(N
, Spec_Id
);
15930 -- Chain the pragma on the contract for completeness
15932 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15934 -- The legality checks of pragma Extension_Visible are affected
15935 -- by the SPARK mode in effect. Analyze all pragmas in specific
15938 Analyze_If_Present
(Pragma_SPARK_Mode
);
15940 -- Examine the formals of the related subprogram
15942 Formal
:= First_Formal
(Spec_Id
);
15943 while Present
(Formal
) loop
15945 -- At least one of the formals is of a specific tagged type,
15946 -- the pragma is legal.
15948 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15949 Has_OK_Formal
:= True;
15952 -- A generic subprogram with at least one formal of a private
15953 -- type ensures the legality of the pragma because the actual
15954 -- may be specifically tagged. Note that this is verified by
15955 -- the check above at instantiation time.
15957 elsif Is_Private_Type
(Etype
(Formal
))
15958 and then Is_Generic_Type
(Etype
(Formal
))
15960 Has_OK_Formal
:= True;
15964 Next_Formal
(Formal
);
15967 if not Has_OK_Formal
then
15968 Error_Msg_Name_1
:= Pname
;
15969 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15971 ("\subprogram & lacks parameter of specific tagged or "
15972 & "generic private type", N
, Spec_Id
);
15977 -- Analyze the Boolean expression (if any)
15979 if Present
(Arg1
) then
15980 Check_Static_Boolean_Expression
15981 (Expression
(Get_Argument
(N
, Spec_Id
)));
15983 end Extensions_Visible
;
15989 -- pragma External (
15990 -- [ Convention =>] convention_IDENTIFIER,
15991 -- [ Entity =>] LOCAL_NAME
15992 -- [, [External_Name =>] static_string_EXPRESSION ]
15993 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15995 when Pragma_External
=> External
: declare
15998 pragma Warnings
(Off
, C
);
16005 Name_External_Name
,
16007 Check_At_Least_N_Arguments
(2);
16008 Check_At_Most_N_Arguments
(4);
16009 Process_Convention
(C
, E
);
16011 -- A pragma that applies to a Ghost entity becomes Ghost for the
16012 -- purposes of legality checks and removal of ignored Ghost code.
16014 Mark_Ghost_Pragma
(N
, E
);
16016 Note_Possible_Modification
16017 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16018 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16019 Set_Exported
(E
, Arg2
);
16022 --------------------------
16023 -- External_Name_Casing --
16024 --------------------------
16026 -- pragma External_Name_Casing (
16027 -- UPPERCASE | LOWERCASE
16028 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16030 when Pragma_External_Name_Casing
=>
16032 Check_No_Identifiers
;
16034 if Arg_Count
= 2 then
16035 Check_Arg_Is_One_Of
16036 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16038 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16040 Opt
.External_Name_Exp_Casing
:= As_Is
;
16042 when Name_Uppercase
=>
16043 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16045 when Name_Lowercase
=>
16046 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16053 Check_Arg_Count
(1);
16056 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16058 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16059 when Name_Uppercase
=>
16060 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16062 when Name_Lowercase
=>
16063 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16073 -- pragma Fast_Math;
16075 when Pragma_Fast_Math
=>
16077 Check_No_Identifiers
;
16078 Check_Valid_Configuration_Pragma
;
16081 --------------------------
16082 -- Favor_Top_Level --
16083 --------------------------
16085 -- pragma Favor_Top_Level (type_NAME);
16087 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16092 Check_No_Identifiers
;
16093 Check_Arg_Count
(1);
16094 Check_Arg_Is_Local_Name
(Arg1
);
16095 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16097 -- A pragma that applies to a Ghost entity becomes Ghost for the
16098 -- purposes of legality checks and removal of ignored Ghost code.
16100 Mark_Ghost_Pragma
(N
, Typ
);
16102 -- If it's an access-to-subprogram type (in particular, not a
16103 -- subtype), set the flag on that type.
16105 if Is_Access_Subprogram_Type
(Typ
) then
16106 Set_Can_Use_Internal_Rep
(Typ
, False);
16108 -- Otherwise it's an error (name denotes the wrong sort of entity)
16112 ("access-to-subprogram type expected",
16113 Get_Pragma_Arg
(Arg1
));
16115 end Favor_Top_Level
;
16117 ---------------------------
16118 -- Finalize_Storage_Only --
16119 ---------------------------
16121 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16123 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16124 Assoc
: constant Node_Id
:= Arg1
;
16125 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16130 Check_No_Identifiers
;
16131 Check_Arg_Count
(1);
16132 Check_Arg_Is_Local_Name
(Arg1
);
16134 Find_Type
(Type_Id
);
16135 Typ
:= Entity
(Type_Id
);
16138 or else Rep_Item_Too_Early
(Typ
, N
)
16142 Typ
:= Underlying_Type
(Typ
);
16145 if not Is_Controlled
(Typ
) then
16146 Error_Pragma
("pragma% must specify controlled type");
16149 Check_First_Subtype
(Arg1
);
16151 if Finalize_Storage_Only
(Typ
) then
16152 Error_Pragma
("duplicate pragma%, only one allowed");
16154 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16155 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16157 end Finalize_Storage
;
16163 -- pragma Ghost [ (boolean_EXPRESSION) ];
16165 when Pragma_Ghost
=> Ghost
: declare
16169 Orig_Stmt
: Node_Id
;
16170 Prev_Id
: Entity_Id
;
16175 Check_No_Identifiers
;
16176 Check_At_Most_N_Arguments
(1);
16180 while Present
(Stmt
) loop
16182 -- Skip prior pragmas, but check for duplicates
16184 if Nkind
(Stmt
) = N_Pragma
then
16185 if Pragma_Name
(Stmt
) = Pname
then
16192 -- Task unit declared without a definition cannot be subject to
16193 -- pragma Ghost (SPARK RM 6.9(19)).
16195 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16196 N_Task_Type_Declaration
)
16198 Error_Pragma
("pragma % cannot apply to a task type");
16201 -- Skip internally generated code
16203 elsif not Comes_From_Source
(Stmt
) then
16204 Orig_Stmt
:= Original_Node
(Stmt
);
16206 -- When pragma Ghost applies to an untagged derivation, the
16207 -- derivation is transformed into a [sub]type declaration.
16209 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16210 N_Subtype_Declaration
)
16211 and then Comes_From_Source
(Orig_Stmt
)
16212 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16213 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16214 N_Derived_Type_Definition
16216 Id
:= Defining_Entity
(Stmt
);
16219 -- When pragma Ghost applies to an object declaration which
16220 -- is initialized by means of a function call that returns
16221 -- on the secondary stack, the object declaration becomes a
16224 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16225 and then Comes_From_Source
(Orig_Stmt
)
16226 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16228 Id
:= Defining_Entity
(Stmt
);
16231 -- When pragma Ghost applies to an expression function, the
16232 -- expression function is transformed into a subprogram.
16234 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16235 and then Comes_From_Source
(Orig_Stmt
)
16236 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16238 Id
:= Defining_Entity
(Stmt
);
16242 -- The pragma applies to a legal construct, stop the traversal
16244 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16245 N_Full_Type_Declaration
,
16246 N_Generic_Subprogram_Declaration
,
16247 N_Object_Declaration
,
16248 N_Private_Extension_Declaration
,
16249 N_Private_Type_Declaration
,
16250 N_Subprogram_Declaration
,
16251 N_Subtype_Declaration
)
16253 Id
:= Defining_Entity
(Stmt
);
16256 -- The pragma does not apply to a legal construct, issue an
16257 -- error and stop the analysis.
16261 ("pragma % must apply to an object, package, subprogram "
16266 Stmt
:= Prev
(Stmt
);
16269 Context
:= Parent
(N
);
16271 -- Handle compilation units
16273 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
16274 Context
:= Unit
(Parent
(Context
));
16277 -- Protected and task types cannot be subject to pragma Ghost
16278 -- (SPARK RM 6.9(19)).
16280 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
16282 Error_Pragma
("pragma % cannot apply to a protected type");
16285 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
16286 Error_Pragma
("pragma % cannot apply to a task type");
16292 -- When pragma Ghost is associated with a [generic] package, it
16293 -- appears in the visible declarations.
16295 if Nkind
(Context
) = N_Package_Specification
16296 and then Present
(Visible_Declarations
(Context
))
16297 and then List_Containing
(N
) = Visible_Declarations
(Context
)
16299 Id
:= Defining_Entity
(Context
);
16301 -- Pragma Ghost applies to a stand-alone subprogram body
16303 elsif Nkind
(Context
) = N_Subprogram_Body
16304 and then No
(Corresponding_Spec
(Context
))
16306 Id
:= Defining_Entity
(Context
);
16308 -- Pragma Ghost applies to a subprogram declaration that acts
16309 -- as a compilation unit.
16311 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
16312 Id
:= Defining_Entity
(Context
);
16314 -- Pragma Ghost applies to a generic subprogram
16316 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
16317 Id
:= Defining_Entity
(Specification
(Context
));
16323 ("pragma % must apply to an object, package, subprogram or "
16328 -- Handle completions of types and constants that are subject to
16331 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
16332 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
16334 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
16335 Error_Msg_Name_1
:= Pname
;
16337 -- The full declaration of a deferred constant cannot be
16338 -- subject to pragma Ghost unless the deferred declaration
16339 -- is also Ghost (SPARK RM 6.9(9)).
16341 if Ekind
(Prev_Id
) = E_Constant
then
16342 Error_Msg_Name_1
:= Pname
;
16343 Error_Msg_NE
(Fix_Error
16344 ("pragma % must apply to declaration of deferred "
16345 & "constant &"), N
, Id
);
16348 -- Pragma Ghost may appear on the full view of an incomplete
16349 -- type because the incomplete declaration lacks aspects and
16350 -- cannot be subject to pragma Ghost.
16352 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
16355 -- The full declaration of a type cannot be subject to
16356 -- pragma Ghost unless the partial view is also Ghost
16357 -- (SPARK RM 6.9(9)).
16360 Error_Msg_NE
(Fix_Error
16361 ("pragma % must apply to partial view of type &"),
16367 -- A synchronized object cannot be subject to pragma Ghost
16368 -- (SPARK RM 6.9(19)).
16370 elsif Ekind
(Id
) = E_Variable
then
16371 if Is_Protected_Type
(Etype
(Id
)) then
16372 Error_Pragma
("pragma % cannot apply to a protected object");
16375 elsif Is_Task_Type
(Etype
(Id
)) then
16376 Error_Pragma
("pragma % cannot apply to a task object");
16381 -- Analyze the Boolean expression (if any)
16383 if Present
(Arg1
) then
16384 Expr
:= Get_Pragma_Arg
(Arg1
);
16386 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
16388 if Is_OK_Static_Expression
(Expr
) then
16390 -- "Ghostness" cannot be turned off once enabled within a
16391 -- region (SPARK RM 6.9(6)).
16393 if Is_False
(Expr_Value
(Expr
))
16394 and then Ghost_Mode
> None
16397 ("pragma % with value False cannot appear in enabled "
16402 -- Otherwie the expression is not static
16406 ("expression of pragma % must be static", Expr
);
16411 Set_Is_Ghost_Entity
(Id
);
16418 -- pragma Global (GLOBAL_SPECIFICATION);
16420 -- GLOBAL_SPECIFICATION ::=
16423 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16425 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16427 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16428 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16429 -- GLOBAL_ITEM ::= NAME
16431 -- Characteristics:
16433 -- * Analysis - The annotation undergoes initial checks to verify
16434 -- the legal placement and context. Secondary checks fully analyze
16435 -- the dependency clauses in:
16437 -- Analyze_Global_In_Decl_Part
16439 -- * Expansion - None.
16441 -- * Template - The annotation utilizes the generic template of the
16442 -- related subprogram [body] when it is:
16444 -- aspect on subprogram declaration
16445 -- aspect on stand-alone subprogram body
16446 -- pragma on stand-alone subprogram body
16448 -- The annotation must prepare its own template when it is:
16450 -- pragma on subprogram declaration
16452 -- * Globals - Capture of global references must occur after full
16455 -- * Instance - The annotation is instantiated automatically when
16456 -- the related generic subprogram [body] is instantiated except for
16457 -- the "pragma on subprogram declaration" case. In that scenario
16458 -- the annotation must instantiate itself.
16460 when Pragma_Global
=> Global
: declare
16462 Spec_Id
: Entity_Id
;
16463 Subp_Decl
: Node_Id
;
16466 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16470 -- Chain the pragma on the contract for further processing by
16471 -- Analyze_Global_In_Decl_Part.
16473 Add_Contract_Item
(N
, Spec_Id
);
16475 -- Fully analyze the pragma when it appears inside an entry
16476 -- or subprogram body because it cannot benefit from forward
16479 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
16481 N_Subprogram_Body_Stub
)
16483 -- The legality checks of pragmas Depends and Global are
16484 -- affected by the SPARK mode in effect and the volatility
16485 -- of the context. In addition these two pragmas are subject
16486 -- to an inherent order:
16491 -- Analyze all these pragmas in the order outlined above
16493 Analyze_If_Present
(Pragma_SPARK_Mode
);
16494 Analyze_If_Present
(Pragma_Volatile_Function
);
16495 Analyze_Global_In_Decl_Part
(N
);
16496 Analyze_If_Present
(Pragma_Depends
);
16505 -- pragma Ident (static_string_EXPRESSION)
16507 -- Note: pragma Comment shares this processing. Pragma Ident is
16508 -- identical in effect to pragma Commment.
16510 when Pragma_Comment
16518 Check_Arg_Count
(1);
16519 Check_No_Identifiers
;
16520 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16523 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
16530 GP
:= Parent
(Parent
(N
));
16532 if Nkind_In
(GP
, N_Package_Declaration
,
16533 N_Generic_Package_Declaration
)
16538 -- If we have a compilation unit, then record the ident value,
16539 -- checking for improper duplication.
16541 if Nkind
(GP
) = N_Compilation_Unit
then
16542 CS
:= Ident_String
(Current_Sem_Unit
);
16544 if Present
(CS
) then
16546 -- If we have multiple instances, concatenate them, but
16547 -- not in ASIS, where we want the original tree.
16549 if not ASIS_Mode
then
16550 Start_String
(Strval
(CS
));
16551 Store_String_Char
(' ');
16552 Store_String_Chars
(Strval
(Str
));
16553 Set_Strval
(CS
, End_String
);
16557 Set_Ident_String
(Current_Sem_Unit
, Str
);
16560 -- For subunits, we just ignore the Ident, since in GNAT these
16561 -- are not separate object files, and hence not separate units
16562 -- in the unit table.
16564 elsif Nkind
(GP
) = N_Subunit
then
16570 -------------------
16571 -- Ignore_Pragma --
16572 -------------------
16574 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16576 -- Entirely handled in the parser, nothing to do here
16578 when Pragma_Ignore_Pragma
=>
16581 ----------------------------
16582 -- Implementation_Defined --
16583 ----------------------------
16585 -- pragma Implementation_Defined (LOCAL_NAME);
16587 -- Marks previously declared entity as implementation defined. For
16588 -- an overloaded entity, applies to the most recent homonym.
16590 -- pragma Implementation_Defined;
16592 -- The form with no arguments appears anywhere within a scope, most
16593 -- typically a package spec, and indicates that all entities that are
16594 -- defined within the package spec are Implementation_Defined.
16596 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
16601 Check_No_Identifiers
;
16603 -- Form with no arguments
16605 if Arg_Count
= 0 then
16606 Set_Is_Implementation_Defined
(Current_Scope
);
16608 -- Form with one argument
16611 Check_Arg_Count
(1);
16612 Check_Arg_Is_Local_Name
(Arg1
);
16613 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
16614 Set_Is_Implementation_Defined
(Ent
);
16616 end Implementation_Defined
;
16622 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16624 -- IMPLEMENTATION_KIND ::=
16625 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16627 -- "By_Any" and "Optional" are treated as synonyms in order to
16628 -- support Ada 2012 aspect Synchronization.
16630 when Pragma_Implemented
=> Implemented
: declare
16631 Proc_Id
: Entity_Id
;
16636 Check_Arg_Count
(2);
16637 Check_No_Identifiers
;
16638 Check_Arg_Is_Identifier
(Arg1
);
16639 Check_Arg_Is_Local_Name
(Arg1
);
16640 Check_Arg_Is_One_Of
(Arg2
,
16643 Name_By_Protected_Procedure
,
16646 -- Extract the name of the local procedure
16648 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16650 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16651 -- primitive procedure of a synchronized tagged type.
16653 if Ekind
(Proc_Id
) = E_Procedure
16654 and then Is_Primitive
(Proc_Id
)
16655 and then Present
(First_Formal
(Proc_Id
))
16657 Typ
:= Etype
(First_Formal
(Proc_Id
));
16659 if Is_Tagged_Type
(Typ
)
16662 -- Check for a protected, a synchronized or a task interface
16664 ((Is_Interface
(Typ
)
16665 and then Is_Synchronized_Interface
(Typ
))
16667 -- Check for a protected type or a task type that implements
16671 (Is_Concurrent_Record_Type
(Typ
)
16672 and then Present
(Interfaces
(Typ
)))
16674 -- In analysis-only mode, examine original protected type
16677 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16678 and then Present
(Interface_List
(Parent
(Typ
))))
16680 -- Check for a private record extension with keyword
16684 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16685 E_Record_Subtype_With_Private
)
16686 and then Synchronized_Present
(Parent
(Typ
))))
16691 ("controlling formal must be of synchronized tagged type",
16696 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16697 -- By_Protected_Procedure to the primitive procedure of a task
16700 if Chars
(Arg2
) = Name_By_Protected_Procedure
16701 and then Is_Interface
(Typ
)
16702 and then Is_Task_Interface
(Typ
)
16705 ("implementation kind By_Protected_Procedure cannot be "
16706 & "applied to a task interface primitive", Arg2
);
16710 -- Procedures declared inside a protected type must be accepted
16712 elsif Ekind
(Proc_Id
) = E_Procedure
16713 and then Is_Protected_Type
(Scope
(Proc_Id
))
16717 -- The first argument is not a primitive procedure
16721 ("pragma % must be applied to a primitive procedure", Arg1
);
16725 Record_Rep_Item
(Proc_Id
, N
);
16728 ----------------------
16729 -- Implicit_Packing --
16730 ----------------------
16732 -- pragma Implicit_Packing;
16734 when Pragma_Implicit_Packing
=>
16736 Check_Arg_Count
(0);
16737 Implicit_Packing
:= True;
16744 -- [Convention =>] convention_IDENTIFIER,
16745 -- [Entity =>] LOCAL_NAME
16746 -- [, [External_Name =>] static_string_EXPRESSION ]
16747 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16749 when Pragma_Import
=>
16750 Check_Ada_83_Warning
;
16754 Name_External_Name
,
16757 Check_At_Least_N_Arguments
(2);
16758 Check_At_Most_N_Arguments
(4);
16759 Process_Import_Or_Interface
;
16761 ---------------------
16762 -- Import_Function --
16763 ---------------------
16765 -- pragma Import_Function (
16766 -- [Internal =>] LOCAL_NAME,
16767 -- [, [External =>] EXTERNAL_SYMBOL]
16768 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16769 -- [, [Result_Type =>] SUBTYPE_MARK]
16770 -- [, [Mechanism =>] MECHANISM]
16771 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16773 -- EXTERNAL_SYMBOL ::=
16775 -- | static_string_EXPRESSION
16777 -- PARAMETER_TYPES ::=
16779 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16781 -- TYPE_DESIGNATOR ::=
16783 -- | subtype_Name ' Access
16787 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16789 -- MECHANISM_ASSOCIATION ::=
16790 -- [formal_parameter_NAME =>] MECHANISM_NAME
16792 -- MECHANISM_NAME ::=
16796 when Pragma_Import_Function
=> Import_Function
: declare
16797 Args
: Args_List
(1 .. 6);
16798 Names
: constant Name_List
(1 .. 6) := (
16801 Name_Parameter_Types
,
16804 Name_Result_Mechanism
);
16806 Internal
: Node_Id
renames Args
(1);
16807 External
: Node_Id
renames Args
(2);
16808 Parameter_Types
: Node_Id
renames Args
(3);
16809 Result_Type
: Node_Id
renames Args
(4);
16810 Mechanism
: Node_Id
renames Args
(5);
16811 Result_Mechanism
: Node_Id
renames Args
(6);
16815 Gather_Associations
(Names
, Args
);
16816 Process_Extended_Import_Export_Subprogram_Pragma
(
16817 Arg_Internal
=> Internal
,
16818 Arg_External
=> External
,
16819 Arg_Parameter_Types
=> Parameter_Types
,
16820 Arg_Result_Type
=> Result_Type
,
16821 Arg_Mechanism
=> Mechanism
,
16822 Arg_Result_Mechanism
=> Result_Mechanism
);
16823 end Import_Function
;
16825 -------------------
16826 -- Import_Object --
16827 -------------------
16829 -- pragma Import_Object (
16830 -- [Internal =>] LOCAL_NAME
16831 -- [, [External =>] EXTERNAL_SYMBOL]
16832 -- [, [Size =>] EXTERNAL_SYMBOL]);
16834 -- EXTERNAL_SYMBOL ::=
16836 -- | static_string_EXPRESSION
16838 when Pragma_Import_Object
=> Import_Object
: declare
16839 Args
: Args_List
(1 .. 3);
16840 Names
: constant Name_List
(1 .. 3) := (
16845 Internal
: Node_Id
renames Args
(1);
16846 External
: Node_Id
renames Args
(2);
16847 Size
: Node_Id
renames Args
(3);
16851 Gather_Associations
(Names
, Args
);
16852 Process_Extended_Import_Export_Object_Pragma
(
16853 Arg_Internal
=> Internal
,
16854 Arg_External
=> External
,
16858 ----------------------
16859 -- Import_Procedure --
16860 ----------------------
16862 -- pragma Import_Procedure (
16863 -- [Internal =>] LOCAL_NAME
16864 -- [, [External =>] EXTERNAL_SYMBOL]
16865 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16866 -- [, [Mechanism =>] MECHANISM]);
16868 -- EXTERNAL_SYMBOL ::=
16870 -- | static_string_EXPRESSION
16872 -- PARAMETER_TYPES ::=
16874 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16876 -- TYPE_DESIGNATOR ::=
16878 -- | subtype_Name ' Access
16882 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16884 -- MECHANISM_ASSOCIATION ::=
16885 -- [formal_parameter_NAME =>] MECHANISM_NAME
16887 -- MECHANISM_NAME ::=
16891 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16892 Args
: Args_List
(1 .. 4);
16893 Names
: constant Name_List
(1 .. 4) := (
16896 Name_Parameter_Types
,
16899 Internal
: Node_Id
renames Args
(1);
16900 External
: Node_Id
renames Args
(2);
16901 Parameter_Types
: Node_Id
renames Args
(3);
16902 Mechanism
: Node_Id
renames Args
(4);
16906 Gather_Associations
(Names
, Args
);
16907 Process_Extended_Import_Export_Subprogram_Pragma
(
16908 Arg_Internal
=> Internal
,
16909 Arg_External
=> External
,
16910 Arg_Parameter_Types
=> Parameter_Types
,
16911 Arg_Mechanism
=> Mechanism
);
16912 end Import_Procedure
;
16914 -----------------------------
16915 -- Import_Valued_Procedure --
16916 -----------------------------
16918 -- pragma Import_Valued_Procedure (
16919 -- [Internal =>] LOCAL_NAME
16920 -- [, [External =>] EXTERNAL_SYMBOL]
16921 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16922 -- [, [Mechanism =>] MECHANISM]);
16924 -- EXTERNAL_SYMBOL ::=
16926 -- | static_string_EXPRESSION
16928 -- PARAMETER_TYPES ::=
16930 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16932 -- TYPE_DESIGNATOR ::=
16934 -- | subtype_Name ' Access
16938 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16940 -- MECHANISM_ASSOCIATION ::=
16941 -- [formal_parameter_NAME =>] MECHANISM_NAME
16943 -- MECHANISM_NAME ::=
16947 when Pragma_Import_Valued_Procedure
=>
16948 Import_Valued_Procedure
: declare
16949 Args
: Args_List
(1 .. 4);
16950 Names
: constant Name_List
(1 .. 4) := (
16953 Name_Parameter_Types
,
16956 Internal
: Node_Id
renames Args
(1);
16957 External
: Node_Id
renames Args
(2);
16958 Parameter_Types
: Node_Id
renames Args
(3);
16959 Mechanism
: Node_Id
renames Args
(4);
16963 Gather_Associations
(Names
, Args
);
16964 Process_Extended_Import_Export_Subprogram_Pragma
(
16965 Arg_Internal
=> Internal
,
16966 Arg_External
=> External
,
16967 Arg_Parameter_Types
=> Parameter_Types
,
16968 Arg_Mechanism
=> Mechanism
);
16969 end Import_Valued_Procedure
;
16975 -- pragma Independent (LOCAL_NAME);
16977 when Pragma_Independent
=>
16978 Process_Atomic_Independent_Shared_Volatile
;
16980 ----------------------------
16981 -- Independent_Components --
16982 ----------------------------
16984 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16986 when Pragma_Independent_Components
=> Independent_Components
: declare
16994 Check_Ada_83_Warning
;
16996 Check_No_Identifiers
;
16997 Check_Arg_Count
(1);
16998 Check_Arg_Is_Local_Name
(Arg1
);
16999 E_Id
:= Get_Pragma_Arg
(Arg1
);
17001 if Etype
(E_Id
) = Any_Type
then
17005 E
:= Entity
(E_Id
);
17007 -- A record type with a self-referential component of anonymous
17008 -- access type is given an incomplete view in order to handle the
17011 -- type Rec is record
17012 -- Self : access Rec;
17018 -- type Ptr is access Rec;
17019 -- type Rec is record
17023 -- Since the incomplete view is now the initial view of the type,
17024 -- the argument of the pragma will reference the incomplete view,
17025 -- but this view is illegal according to the semantics of the
17028 -- Obtain the full view of an internally-generated incomplete type
17029 -- only. This way an attempt to associate the pragma with a source
17030 -- incomplete type is still caught.
17032 if Ekind
(E
) = E_Incomplete_Type
17033 and then not Comes_From_Source
(E
)
17034 and then Present
(Full_View
(E
))
17036 E
:= Full_View
(E
);
17039 -- A pragma that applies to a Ghost entity becomes Ghost for the
17040 -- purposes of legality checks and removal of ignored Ghost code.
17042 Mark_Ghost_Pragma
(N
, E
);
17044 -- Check duplicate before we chain ourselves
17046 Check_Duplicate_Pragma
(E
);
17048 -- Check appropriate entity
17050 if Rep_Item_Too_Early
(E
, N
)
17052 Rep_Item_Too_Late
(E
, N
)
17057 D
:= Declaration_Node
(E
);
17060 -- The flag is set on the base type, or on the object
17062 if K
= N_Full_Type_Declaration
17063 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17065 Set_Has_Independent_Components
(Base_Type
(E
));
17066 Record_Independence_Check
(N
, Base_Type
(E
));
17068 -- For record type, set all components independent
17070 if Is_Record_Type
(E
) then
17071 C
:= First_Component
(E
);
17072 while Present
(C
) loop
17073 Set_Is_Independent
(C
);
17074 Next_Component
(C
);
17078 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17079 and then Nkind
(D
) = N_Object_Declaration
17080 and then Nkind
(Object_Definition
(D
)) =
17081 N_Constrained_Array_Definition
17083 Set_Has_Independent_Components
(E
);
17084 Record_Independence_Check
(N
, E
);
17087 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17089 end Independent_Components
;
17091 -----------------------
17092 -- Initial_Condition --
17093 -----------------------
17095 -- pragma Initial_Condition (boolean_EXPRESSION);
17097 -- Characteristics:
17099 -- * Analysis - The annotation undergoes initial checks to verify
17100 -- the legal placement and context. Secondary checks preanalyze the
17103 -- Analyze_Initial_Condition_In_Decl_Part
17105 -- * Expansion - The annotation is expanded during the expansion of
17106 -- the package body whose declaration is subject to the annotation
17109 -- Expand_Pragma_Initial_Condition
17111 -- * Template - The annotation utilizes the generic template of the
17112 -- related package declaration.
17114 -- * Globals - Capture of global references must occur after full
17117 -- * Instance - The annotation is instantiated automatically when
17118 -- the related generic package is instantiated.
17120 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17121 Pack_Decl
: Node_Id
;
17122 Pack_Id
: Entity_Id
;
17126 Check_No_Identifiers
;
17127 Check_Arg_Count
(1);
17129 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17131 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17132 N_Package_Declaration
)
17138 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17140 -- A pragma that applies to a Ghost entity becomes Ghost for the
17141 -- purposes of legality checks and removal of ignored Ghost code.
17143 Mark_Ghost_Pragma
(N
, Pack_Id
);
17145 -- Chain the pragma on the contract for further processing by
17146 -- Analyze_Initial_Condition_In_Decl_Part.
17148 Add_Contract_Item
(N
, Pack_Id
);
17150 -- The legality checks of pragmas Abstract_State, Initializes, and
17151 -- Initial_Condition are affected by the SPARK mode in effect. In
17152 -- addition, these three pragmas are subject to an inherent order:
17154 -- 1) Abstract_State
17156 -- 3) Initial_Condition
17158 -- Analyze all these pragmas in the order outlined above
17160 Analyze_If_Present
(Pragma_SPARK_Mode
);
17161 Analyze_If_Present
(Pragma_Abstract_State
);
17162 Analyze_If_Present
(Pragma_Initializes
);
17163 end Initial_Condition
;
17165 ------------------------
17166 -- Initialize_Scalars --
17167 ------------------------
17169 -- pragma Initialize_Scalars
17170 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17172 -- TYPE_VALUE_PAIR ::=
17173 -- SCALAR_TYPE => static_EXPRESSION
17179 -- | Long_Long_Flat
17189 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
17190 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
17191 -- This collection holds the individual pairs which specify the
17192 -- invalid values of their respective scalar types.
17194 procedure Analyze_Float_Value
17195 (Scal_Typ
: Float_Scalar_Id
;
17196 Val_Expr
: Node_Id
);
17197 -- Analyze a type value pair associated with float type Scal_Typ
17198 -- and expression Val_Expr.
17200 procedure Analyze_Integer_Value
17201 (Scal_Typ
: Integer_Scalar_Id
;
17202 Val_Expr
: Node_Id
);
17203 -- Analyze a type value pair associated with integer type Scal_Typ
17204 -- and expression Val_Expr.
17206 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
17207 -- Analyze type value pair Pair
17209 -------------------------
17210 -- Analyze_Float_Value --
17211 -------------------------
17213 procedure Analyze_Float_Value
17214 (Scal_Typ
: Float_Scalar_Id
;
17215 Val_Expr
: Node_Id
)
17218 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
17220 if Is_OK_Static_Expression
(Val_Expr
) then
17221 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
17224 Error_Msg_Name_1
:= Scal_Typ
;
17225 Error_Msg_N
("value for type % must be static", Val_Expr
);
17227 end Analyze_Float_Value
;
17229 ---------------------------
17230 -- Analyze_Integer_Value --
17231 ---------------------------
17233 procedure Analyze_Integer_Value
17234 (Scal_Typ
: Integer_Scalar_Id
;
17235 Val_Expr
: Node_Id
)
17238 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
17240 if Is_OK_Static_Expression
(Val_Expr
) then
17241 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
17244 Error_Msg_Name_1
:= Scal_Typ
;
17245 Error_Msg_N
("value for type % must be static", Val_Expr
);
17247 end Analyze_Integer_Value
;
17249 -----------------------------
17250 -- Analyze_Type_Value_Pair --
17251 -----------------------------
17253 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
17254 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
17255 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
17256 Prev_Pair
: Node_Id
;
17259 if Scal_Typ
in Scalar_Id
then
17260 Prev_Pair
:= Seen
(Scal_Typ
);
17262 -- Prevent multiple attempts to set a value for a scalar
17265 if Present
(Prev_Pair
) then
17266 Error_Msg_Name_1
:= Scal_Typ
;
17268 ("cannot specify multiple invalid values for type %",
17271 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
17272 Error_Msg_N
("previous value set #", Pair
);
17274 -- Ignore the effects of the pair, but do not halt the
17275 -- analysis of the pragma altogether.
17279 -- Otherwise capture the first pair for this scalar type
17282 Seen
(Scal_Typ
) := Pair
;
17285 if Scal_Typ
in Float_Scalar_Id
then
17286 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
17288 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
17289 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
17292 -- Otherwise the scalar family is illegal
17295 Error_Msg_Name_1
:= Pname
;
17297 ("argument of pragma % must denote valid scalar family",
17300 end Analyze_Type_Value_Pair
;
17304 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
17307 -- Start of processing for Do_Initialize_Scalars
17311 Check_Valid_Configuration_Pragma
;
17312 Check_Restriction
(No_Initialize_Scalars
, N
);
17314 -- Ignore the effects of the pragma when No_Initialize_Scalars is
17317 if Restriction_Active
(No_Initialize_Scalars
) then
17320 -- Initialize_Scalars creates false positives in CodePeer, and
17321 -- incorrect negative results in GNATprove mode, so ignore this
17322 -- pragma in these modes.
17324 elsif CodePeer_Mode
or GNATprove_Mode
then
17327 -- Otherwise analyze the pragma
17330 if Present
(Pairs
) then
17332 -- Install Standard in order to provide access to primitive
17333 -- types in case the expressions contain attributes such as
17336 Push_Scope
(Standard_Standard
);
17338 Pair
:= First
(Pairs
);
17339 while Present
(Pair
) loop
17340 Analyze_Type_Value_Pair
(Pair
);
17349 Init_Or_Norm_Scalars
:= True;
17350 Initialize_Scalars
:= True;
17352 end Do_Initialize_Scalars
;
17358 -- pragma Initializes (INITIALIZATION_LIST);
17360 -- INITIALIZATION_LIST ::=
17362 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
17364 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
17369 -- | (INPUT {, INPUT})
17373 -- Characteristics:
17375 -- * Analysis - The annotation undergoes initial checks to verify
17376 -- the legal placement and context. Secondary checks preanalyze the
17379 -- Analyze_Initializes_In_Decl_Part
17381 -- * Expansion - None.
17383 -- * Template - The annotation utilizes the generic template of the
17384 -- related package declaration.
17386 -- * Globals - Capture of global references must occur after full
17389 -- * Instance - The annotation is instantiated automatically when
17390 -- the related generic package is instantiated.
17392 when Pragma_Initializes
=> Initializes
: declare
17393 Pack_Decl
: Node_Id
;
17394 Pack_Id
: Entity_Id
;
17398 Check_No_Identifiers
;
17399 Check_Arg_Count
(1);
17401 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17403 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17404 N_Package_Declaration
)
17410 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17412 -- A pragma that applies to a Ghost entity becomes Ghost for the
17413 -- purposes of legality checks and removal of ignored Ghost code.
17415 Mark_Ghost_Pragma
(N
, Pack_Id
);
17416 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
17418 -- Chain the pragma on the contract for further processing by
17419 -- Analyze_Initializes_In_Decl_Part.
17421 Add_Contract_Item
(N
, Pack_Id
);
17423 -- The legality checks of pragmas Abstract_State, Initializes, and
17424 -- Initial_Condition are affected by the SPARK mode in effect. In
17425 -- addition, these three pragmas are subject to an inherent order:
17427 -- 1) Abstract_State
17429 -- 3) Initial_Condition
17431 -- Analyze all these pragmas in the order outlined above
17433 Analyze_If_Present
(Pragma_SPARK_Mode
);
17434 Analyze_If_Present
(Pragma_Abstract_State
);
17435 Analyze_If_Present
(Pragma_Initial_Condition
);
17442 -- pragma Inline ( NAME {, NAME} );
17444 when Pragma_Inline
=>
17446 -- Pragma always active unless in GNATprove mode. It is disabled
17447 -- in GNATprove mode because frontend inlining is applied
17448 -- independently of pragmas Inline and Inline_Always for
17449 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17452 if not GNATprove_Mode
then
17454 -- Inline status is Enabled if option -gnatn is specified.
17455 -- However this status determines only the value of the
17456 -- Is_Inlined flag on the subprogram and does not prevent
17457 -- the pragma itself from being recorded for later use,
17458 -- in particular for a later modification of Is_Inlined
17459 -- independently of the -gnatn option.
17461 -- In other words, if -gnatn is specified for a unit, then
17462 -- all Inline pragmas processed for the compilation of this
17463 -- unit, including those in the spec of other units, are
17464 -- activated, so subprograms will be inlined across units.
17466 -- If -gnatn is not specified, no Inline pragma is activated
17467 -- here, which means that subprograms will not be inlined
17468 -- across units. The Is_Inlined flag will nevertheless be
17469 -- set later when bodies are analyzed, so subprograms will
17470 -- be inlined within the unit.
17472 if Inline_Active
then
17473 Process_Inline
(Enabled
);
17475 Process_Inline
(Disabled
);
17479 -------------------
17480 -- Inline_Always --
17481 -------------------
17483 -- pragma Inline_Always ( NAME {, NAME} );
17485 when Pragma_Inline_Always
=>
17488 -- Pragma always active unless in CodePeer mode or GNATprove
17489 -- mode. It is disabled in CodePeer mode because inlining is
17490 -- not helpful, and enabling it caused walk order issues. It
17491 -- is disabled in GNATprove mode because frontend inlining is
17492 -- applied independently of pragmas Inline and Inline_Always for
17493 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17496 if not CodePeer_Mode
and not GNATprove_Mode
then
17497 Process_Inline
(Enabled
);
17500 --------------------
17501 -- Inline_Generic --
17502 --------------------
17504 -- pragma Inline_Generic (NAME {, NAME});
17506 when Pragma_Inline_Generic
=>
17508 Process_Generic_List
;
17510 ----------------------
17511 -- Inspection_Point --
17512 ----------------------
17514 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17516 when Pragma_Inspection_Point
=> Inspection_Point
: declare
17523 if Arg_Count
> 0 then
17526 Exp
:= Get_Pragma_Arg
(Arg
);
17529 if not Is_Entity_Name
(Exp
)
17530 or else not Is_Object
(Entity
(Exp
))
17532 Error_Pragma_Arg
("object name required", Arg
);
17536 exit when No
(Arg
);
17539 end Inspection_Point
;
17545 -- pragma Interface (
17546 -- [ Convention =>] convention_IDENTIFIER,
17547 -- [ Entity =>] LOCAL_NAME
17548 -- [, [External_Name =>] static_string_EXPRESSION ]
17549 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17551 when Pragma_Interface
=>
17556 Name_External_Name
,
17558 Check_At_Least_N_Arguments
(2);
17559 Check_At_Most_N_Arguments
(4);
17560 Process_Import_Or_Interface
;
17562 -- In Ada 2005, the permission to use Interface (a reserved word)
17563 -- as a pragma name is considered an obsolescent feature, and this
17564 -- pragma was already obsolescent in Ada 95.
17566 if Ada_Version
>= Ada_95
then
17568 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
17570 if Warn_On_Obsolescent_Feature
then
17572 ("pragma Interface is an obsolescent feature?j?", N
);
17574 ("|use pragma Import instead?j?", N
);
17578 --------------------
17579 -- Interface_Name --
17580 --------------------
17582 -- pragma Interface_Name (
17583 -- [ Entity =>] LOCAL_NAME
17584 -- [,[External_Name =>] static_string_EXPRESSION ]
17585 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17587 when Pragma_Interface_Name
=> Interface_Name
: declare
17589 Def_Id
: Entity_Id
;
17590 Hom_Id
: Entity_Id
;
17596 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
17597 Check_At_Least_N_Arguments
(2);
17598 Check_At_Most_N_Arguments
(3);
17599 Id
:= Get_Pragma_Arg
(Arg1
);
17602 -- This is obsolete from Ada 95 on, but it is an implementation
17603 -- defined pragma, so we do not consider that it violates the
17604 -- restriction (No_Obsolescent_Features).
17606 if Ada_Version
>= Ada_95
then
17607 if Warn_On_Obsolescent_Feature
then
17609 ("pragma Interface_Name is an obsolescent feature?j?", N
);
17611 ("|use pragma Import instead?j?", N
);
17615 if not Is_Entity_Name
(Id
) then
17617 ("first argument for pragma% must be entity name", Arg1
);
17618 elsif Etype
(Id
) = Any_Type
then
17621 Def_Id
:= Entity
(Id
);
17624 -- Special DEC-compatible processing for the object case, forces
17625 -- object to be imported.
17627 if Ekind
(Def_Id
) = E_Variable
then
17628 Kill_Size_Check_Code
(Def_Id
);
17629 Note_Possible_Modification
(Id
, Sure
=> False);
17631 -- Initialization is not allowed for imported variable
17633 if Present
(Expression
(Parent
(Def_Id
)))
17634 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
17636 Error_Msg_Sloc
:= Sloc
(Def_Id
);
17638 ("no initialization allowed for declaration of& #",
17642 -- For compatibility, support VADS usage of providing both
17643 -- pragmas Interface and Interface_Name to obtain the effect
17644 -- of a single Import pragma.
17646 if Is_Imported
(Def_Id
)
17647 and then Present
(First_Rep_Item
(Def_Id
))
17648 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
17649 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
17654 Set_Imported
(Def_Id
);
17657 Set_Is_Public
(Def_Id
);
17658 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17661 -- Otherwise must be subprogram
17663 elsif not Is_Subprogram
(Def_Id
) then
17665 ("argument of pragma% is not subprogram", Arg1
);
17668 Check_At_Most_N_Arguments
(3);
17672 -- Loop through homonyms
17675 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
17677 if Is_Imported
(Def_Id
) then
17678 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17682 exit when From_Aspect_Specification
(N
);
17683 Hom_Id
:= Homonym
(Hom_Id
);
17685 exit when No
(Hom_Id
)
17686 or else Scope
(Hom_Id
) /= Current_Scope
;
17691 ("argument of pragma% is not imported subprogram",
17695 end Interface_Name
;
17697 -----------------------
17698 -- Interrupt_Handler --
17699 -----------------------
17701 -- pragma Interrupt_Handler (handler_NAME);
17703 when Pragma_Interrupt_Handler
=>
17704 Check_Ada_83_Warning
;
17705 Check_Arg_Count
(1);
17706 Check_No_Identifiers
;
17708 if No_Run_Time_Mode
then
17709 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
17711 Check_Interrupt_Or_Attach_Handler
;
17712 Process_Interrupt_Or_Attach_Handler
;
17715 ------------------------
17716 -- Interrupt_Priority --
17717 ------------------------
17719 -- pragma Interrupt_Priority [(EXPRESSION)];
17721 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
17722 P
: constant Node_Id
:= Parent
(N
);
17727 Check_Ada_83_Warning
;
17729 if Arg_Count
/= 0 then
17730 Arg
:= Get_Pragma_Arg
(Arg1
);
17731 Check_Arg_Count
(1);
17732 Check_No_Identifiers
;
17734 -- The expression must be analyzed in the special manner
17735 -- described in "Handling of Default and Per-Object
17736 -- Expressions" in sem.ads.
17738 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
17741 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
17746 Ent
:= Defining_Identifier
(Parent
(P
));
17748 -- Check duplicate pragma before we chain the pragma in the Rep
17749 -- Item chain of Ent.
17751 Check_Duplicate_Pragma
(Ent
);
17752 Record_Rep_Item
(Ent
, N
);
17754 -- Check the No_Task_At_Interrupt_Priority restriction
17756 if Nkind
(P
) = N_Task_Definition
then
17757 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
17760 end Interrupt_Priority
;
17762 ---------------------
17763 -- Interrupt_State --
17764 ---------------------
17766 -- pragma Interrupt_State (
17767 -- [Name =>] INTERRUPT_ID,
17768 -- [State =>] INTERRUPT_STATE);
17770 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
17771 -- INTERRUPT_STATE => System | Runtime | User
17773 -- Note: if the interrupt id is given as an identifier, then it must
17774 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
17775 -- given as a static integer expression which must be in the range of
17776 -- Ada.Interrupts.Interrupt_ID.
17778 when Pragma_Interrupt_State
=> Interrupt_State
: declare
17779 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
17780 -- This is the entity Ada.Interrupts.Interrupt_ID;
17782 State_Type
: Character;
17783 -- Set to 's'/'r'/'u' for System/Runtime/User
17786 -- Index to entry in Interrupt_States table
17789 -- Value of interrupt
17791 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17792 -- The first argument to the pragma
17794 Int_Ent
: Entity_Id
;
17795 -- Interrupt entity in Ada.Interrupts.Names
17799 Check_Arg_Order
((Name_Name
, Name_State
));
17800 Check_Arg_Count
(2);
17802 Check_Optional_Identifier
(Arg1
, Name_Name
);
17803 Check_Optional_Identifier
(Arg2
, Name_State
);
17804 Check_Arg_Is_Identifier
(Arg2
);
17806 -- First argument is identifier
17808 if Nkind
(Arg1X
) = N_Identifier
then
17810 -- Search list of names in Ada.Interrupts.Names
17812 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
17814 if No
(Int_Ent
) then
17815 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
17817 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
17818 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
17822 Next_Entity
(Int_Ent
);
17825 -- First argument is not an identifier, so it must be a static
17826 -- expression of type Ada.Interrupts.Interrupt_ID.
17829 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
17830 Int_Val
:= Expr_Value
(Arg1X
);
17832 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
17834 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17837 ("value not in range of type "
17838 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17844 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17845 when Name_Runtime
=> State_Type
:= 'r';
17846 when Name_System
=> State_Type
:= 's';
17847 when Name_User
=> State_Type
:= 'u';
17850 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17853 -- Check if entry is already stored
17855 IST_Num
:= Interrupt_States
.First
;
17857 -- If entry not found, add it
17859 if IST_Num
> Interrupt_States
.Last
then
17860 Interrupt_States
.Append
17861 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17862 Interrupt_State
=> State_Type
,
17863 Pragma_Loc
=> Loc
));
17866 -- Case of entry for the same entry
17868 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17871 -- If state matches, done, no need to make redundant entry
17874 State_Type
= Interrupt_States
.Table
(IST_Num
).
17877 -- Otherwise if state does not match, error
17880 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17882 ("state conflicts with that given #", Arg2
);
17886 IST_Num
:= IST_Num
+ 1;
17888 end Interrupt_State
;
17894 -- pragma Invariant
17895 -- ([Entity =>] type_LOCAL_NAME,
17896 -- [Check =>] EXPRESSION
17897 -- [,[Message =>] String_Expression]);
17899 when Pragma_Invariant
=> Invariant
: declare
17906 Check_At_Least_N_Arguments
(2);
17907 Check_At_Most_N_Arguments
(3);
17908 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17909 Check_Optional_Identifier
(Arg2
, Name_Check
);
17911 if Arg_Count
= 3 then
17912 Check_Optional_Identifier
(Arg3
, Name_Message
);
17913 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17916 Check_Arg_Is_Local_Name
(Arg1
);
17918 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17919 Find_Type
(Typ_Arg
);
17920 Typ
:= Entity
(Typ_Arg
);
17922 -- Nothing to do of the related type is erroneous in some way
17924 if Typ
= Any_Type
then
17927 -- AI12-0041: Invariants are allowed in interface types
17929 elsif Is_Interface
(Typ
) then
17932 -- An invariant must apply to a private type, or appear in the
17933 -- private part of a package spec and apply to a completion.
17934 -- a class-wide invariant can only appear on a private declaration
17935 -- or private extension, not a completion.
17937 -- A [class-wide] invariant may be associated a [limited] private
17938 -- type or a private extension.
17940 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17942 E_Record_Type_With_Private
)
17946 -- A non-class-wide invariant may be associated with the full view
17947 -- of a [limited] private type or a private extension.
17949 elsif Has_Private_Declaration
(Typ
)
17950 and then not Class_Present
(N
)
17954 -- A class-wide invariant may appear on the partial view only
17956 elsif Class_Present
(N
) then
17958 ("pragma % only allowed for private type", Arg1
);
17961 -- A regular invariant may appear on both views
17965 ("pragma % only allowed for private type or corresponding "
17966 & "full view", Arg1
);
17970 -- An invariant associated with an abstract type (this includes
17971 -- interfaces) must be class-wide.
17973 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
17975 ("pragma % not allowed for abstract type", Arg1
);
17979 -- A pragma that applies to a Ghost entity becomes Ghost for the
17980 -- purposes of legality checks and removal of ignored Ghost code.
17982 Mark_Ghost_Pragma
(N
, Typ
);
17984 -- The pragma defines a type-specific invariant, the type is said
17985 -- to have invariants of its "own".
17987 Set_Has_Own_Invariants
(Typ
);
17989 -- If the invariant is class-wide, then it can be inherited by
17990 -- derived or interface implementing types. The type is said to
17991 -- have "inheritable" invariants.
17993 if Class_Present
(N
) then
17994 Set_Has_Inheritable_Invariants
(Typ
);
17997 -- Chain the pragma on to the rep item chain, for processing when
17998 -- the type is frozen.
18000 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18002 -- Create the declaration of the invariant procedure that will
18003 -- verify the invariant at run time. Interfaces are treated as the
18004 -- partial view of a private type in order to achieve uniformity
18005 -- with the general case. As a result, an interface receives only
18006 -- a "partial" invariant procedure, which is never called.
18008 Build_Invariant_Procedure_Declaration
18010 Partial_Invariant
=> Is_Interface
(Typ
));
18017 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18019 when Pragma_Keep_Names
=> Keep_Names
: declare
18024 Check_Arg_Count
(1);
18025 Check_Optional_Identifier
(Arg1
, Name_On
);
18026 Check_Arg_Is_Local_Name
(Arg1
);
18028 Arg
:= Get_Pragma_Arg
(Arg1
);
18031 if Etype
(Arg
) = Any_Type
then
18035 if not Is_Entity_Name
(Arg
)
18036 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18039 ("pragma% requires a local enumeration type", Arg1
);
18042 Set_Discard_Names
(Entity
(Arg
), False);
18049 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18051 when Pragma_License
=>
18054 -- Do not analyze pragma any further in CodePeer mode, to avoid
18055 -- extraneous errors in this implementation-dependent pragma,
18056 -- which has a different profile on other compilers.
18058 if CodePeer_Mode
then
18062 Check_Arg_Count
(1);
18063 Check_No_Identifiers
;
18064 Check_Valid_Configuration_Pragma
;
18065 Check_Arg_Is_Identifier
(Arg1
);
18068 Sind
: constant Source_File_Index
:=
18069 Source_Index
(Current_Sem_Unit
);
18072 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18074 Set_License
(Sind
, GPL
);
18076 when Name_Modified_GPL
=>
18077 Set_License
(Sind
, Modified_GPL
);
18079 when Name_Restricted
=>
18080 Set_License
(Sind
, Restricted
);
18082 when Name_Unrestricted
=>
18083 Set_License
(Sind
, Unrestricted
);
18086 Error_Pragma_Arg
("invalid license name", Arg1
);
18094 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18096 when Pragma_Link_With
=> Link_With
: declare
18102 if Operating_Mode
= Generate_Code
18103 and then In_Extended_Main_Source_Unit
(N
)
18105 Check_At_Least_N_Arguments
(1);
18106 Check_No_Identifiers
;
18107 Check_Is_In_Decl_Part_Or_Package_Spec
;
18108 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18112 while Present
(Arg
) loop
18113 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18115 -- Store argument, converting sequences of spaces to a
18116 -- single null character (this is one of the differences
18117 -- in processing between Link_With and Linker_Options).
18119 Arg_Store
: declare
18120 C
: constant Char_Code
:= Get_Char_Code
(' ');
18121 S
: constant String_Id
:=
18122 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18123 L
: constant Nat
:= String_Length
(S
);
18126 procedure Skip_Spaces
;
18127 -- Advance F past any spaces
18133 procedure Skip_Spaces
is
18135 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18140 -- Start of processing for Arg_Store
18143 Skip_Spaces
; -- skip leading spaces
18145 -- Loop through characters, changing any embedded
18146 -- sequence of spaces to a single null character (this
18147 -- is how Link_With/Linker_Options differ)
18150 if Get_String_Char
(S
, F
) = C
then
18153 Store_String_Char
(ASCII
.NUL
);
18156 Store_String_Char
(Get_String_Char
(S
, F
));
18164 if Present
(Arg
) then
18165 Store_String_Char
(ASCII
.NUL
);
18169 Store_Linker_Option_String
(End_String
);
18177 -- pragma Linker_Alias (
18178 -- [Entity =>] LOCAL_NAME
18179 -- [Target =>] static_string_EXPRESSION);
18181 when Pragma_Linker_Alias
=>
18183 Check_Arg_Order
((Name_Entity
, Name_Target
));
18184 Check_Arg_Count
(2);
18185 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18186 Check_Optional_Identifier
(Arg2
, Name_Target
);
18187 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18188 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18190 -- The only processing required is to link this item on to the
18191 -- list of rep items for the given entity. This is accomplished
18192 -- by the call to Rep_Item_Too_Late (when no error is detected
18193 -- and False is returned).
18195 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
18198 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18201 ------------------------
18202 -- Linker_Constructor --
18203 ------------------------
18205 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18207 -- Code is shared with Linker_Destructor
18209 -----------------------
18210 -- Linker_Destructor --
18211 -----------------------
18213 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18215 when Pragma_Linker_Constructor
18216 | Pragma_Linker_Destructor
18218 Linker_Constructor
: declare
18224 Check_Arg_Count
(1);
18225 Check_No_Identifiers
;
18226 Check_Arg_Is_Local_Name
(Arg1
);
18227 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
18229 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
18231 if not Is_Library_Level_Entity
(Proc
) then
18233 ("argument for pragma% must be library level entity", Arg1
);
18236 -- The only processing required is to link this item on to the
18237 -- list of rep items for the given entity. This is accomplished
18238 -- by the call to Rep_Item_Too_Late (when no error is detected
18239 -- and False is returned).
18241 if Rep_Item_Too_Late
(Proc
, N
) then
18244 Set_Has_Gigi_Rep_Item
(Proc
);
18246 end Linker_Constructor
;
18248 --------------------
18249 -- Linker_Options --
18250 --------------------
18252 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18254 when Pragma_Linker_Options
=> Linker_Options
: declare
18258 Check_Ada_83_Warning
;
18259 Check_No_Identifiers
;
18260 Check_Arg_Count
(1);
18261 Check_Is_In_Decl_Part_Or_Package_Spec
;
18262 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18263 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
18266 while Present
(Arg
) loop
18267 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18268 Store_String_Char
(ASCII
.NUL
);
18270 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
18274 if Operating_Mode
= Generate_Code
18275 and then In_Extended_Main_Source_Unit
(N
)
18277 Store_Linker_Option_String
(End_String
);
18279 end Linker_Options
;
18281 --------------------
18282 -- Linker_Section --
18283 --------------------
18285 -- pragma Linker_Section (
18286 -- [Entity =>] LOCAL_NAME
18287 -- [Section =>] static_string_EXPRESSION);
18289 when Pragma_Linker_Section
=> Linker_Section
: declare
18294 Ghost_Error_Posted
: Boolean := False;
18295 -- Flag set when an error concerning the illegal mix of Ghost and
18296 -- non-Ghost subprograms is emitted.
18298 Ghost_Id
: Entity_Id
:= Empty
;
18299 -- The entity of the first Ghost subprogram encountered while
18300 -- processing the arguments of the pragma.
18304 Check_Arg_Order
((Name_Entity
, Name_Section
));
18305 Check_Arg_Count
(2);
18306 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18307 Check_Optional_Identifier
(Arg2
, Name_Section
);
18308 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18309 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18311 -- Check kind of entity
18313 Arg
:= Get_Pragma_Arg
(Arg1
);
18314 Ent
:= Entity
(Arg
);
18316 case Ekind
(Ent
) is
18318 -- Objects (constants and variables) and types. For these cases
18319 -- all we need to do is to set the Linker_Section_pragma field,
18320 -- checking that we do not have a duplicate.
18326 LPE
:= Linker_Section_Pragma
(Ent
);
18328 if Present
(LPE
) then
18329 Error_Msg_Sloc
:= Sloc
(LPE
);
18331 ("Linker_Section already specified for &#", Arg1
, Ent
);
18334 Set_Linker_Section_Pragma
(Ent
, N
);
18336 -- A pragma that applies to a Ghost entity becomes Ghost for
18337 -- the purposes of legality checks and removal of ignored
18340 Mark_Ghost_Pragma
(N
, Ent
);
18344 when Subprogram_Kind
=>
18346 -- Aspect case, entity already set
18348 if From_Aspect_Specification
(N
) then
18349 Set_Linker_Section_Pragma
18350 (Entity
(Corresponding_Aspect
(N
)), N
);
18352 -- Pragma case, we must climb the homonym chain, but skip
18353 -- any for which the linker section is already set.
18357 if No
(Linker_Section_Pragma
(Ent
)) then
18358 Set_Linker_Section_Pragma
(Ent
, N
);
18360 -- A pragma that applies to a Ghost entity becomes
18361 -- Ghost for the purposes of legality checks and
18362 -- removal of ignored Ghost code.
18364 Mark_Ghost_Pragma
(N
, Ent
);
18366 -- Capture the entity of the first Ghost subprogram
18367 -- being processed for error detection purposes.
18369 if Is_Ghost_Entity
(Ent
) then
18370 if No
(Ghost_Id
) then
18374 -- Otherwise the subprogram is non-Ghost. It is
18375 -- illegal to mix references to Ghost and non-Ghost
18376 -- entities (SPARK RM 6.9).
18378 elsif Present
(Ghost_Id
)
18379 and then not Ghost_Error_Posted
18381 Ghost_Error_Posted
:= True;
18383 Error_Msg_Name_1
:= Pname
;
18385 ("pragma % cannot mention ghost and "
18386 & "non-ghost subprograms", N
);
18388 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18390 ("\& # declared as ghost", N
, Ghost_Id
);
18392 Error_Msg_Sloc
:= Sloc
(Ent
);
18394 ("\& # declared as non-ghost", N
, Ent
);
18398 Ent
:= Homonym
(Ent
);
18400 or else Scope
(Ent
) /= Current_Scope
;
18404 -- All other cases are illegal
18408 ("pragma% applies only to objects, subprograms, and types",
18411 end Linker_Section
;
18417 -- pragma List (On | Off)
18419 -- There is nothing to do here, since we did all the processing for
18420 -- this pragma in Par.Prag (so that it works properly even in syntax
18423 when Pragma_List
=>
18430 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18432 when Pragma_Lock_Free
=> Lock_Free
: declare
18433 P
: constant Node_Id
:= Parent
(N
);
18439 Check_No_Identifiers
;
18440 Check_At_Most_N_Arguments
(1);
18442 -- Protected definition case
18444 if Nkind
(P
) = N_Protected_Definition
then
18445 Ent
:= Defining_Identifier
(Parent
(P
));
18449 if Arg_Count
= 1 then
18450 Arg
:= Get_Pragma_Arg
(Arg1
);
18451 Val
:= Is_True
(Static_Boolean
(Arg
));
18453 -- No arguments (expression is considered to be True)
18459 -- Check duplicate pragma before we chain the pragma in the Rep
18460 -- Item chain of Ent.
18462 Check_Duplicate_Pragma
(Ent
);
18463 Record_Rep_Item
(Ent
, N
);
18464 Set_Uses_Lock_Free
(Ent
, Val
);
18466 -- Anything else is incorrect placement
18473 --------------------
18474 -- Locking_Policy --
18475 --------------------
18477 -- pragma Locking_Policy (policy_IDENTIFIER);
18479 when Pragma_Locking_Policy
=> declare
18480 subtype LP_Range
is Name_Id
18481 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
18486 Check_Ada_83_Warning
;
18487 Check_Arg_Count
(1);
18488 Check_No_Identifiers
;
18489 Check_Arg_Is_Locking_Policy
(Arg1
);
18490 Check_Valid_Configuration_Pragma
;
18491 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18494 when Name_Ceiling_Locking
=> LP
:= 'C';
18495 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
18496 when Name_Inheritance_Locking
=> LP
:= 'I';
18499 if Locking_Policy
/= ' '
18500 and then Locking_Policy
/= LP
18502 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18503 Error_Pragma
("locking policy incompatible with policy#");
18505 -- Set new policy, but always preserve System_Location since we
18506 -- like the error message with the run time name.
18509 Locking_Policy
:= LP
;
18511 if Locking_Policy_Sloc
/= System_Location
then
18512 Locking_Policy_Sloc
:= Loc
;
18517 -------------------
18518 -- Loop_Optimize --
18519 -------------------
18521 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18523 -- OPTIMIZATION_HINT ::=
18524 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18526 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
18531 Check_At_Least_N_Arguments
(1);
18532 Check_No_Identifiers
;
18534 Hint
:= First
(Pragma_Argument_Associations
(N
));
18535 while Present
(Hint
) loop
18536 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
18544 Check_Loop_Pragma_Placement
;
18551 -- pragma Loop_Variant
18552 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18554 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18556 -- CHANGE_DIRECTION ::= Increases | Decreases
18558 when Pragma_Loop_Variant
=> Loop_Variant
: declare
18563 Check_At_Least_N_Arguments
(1);
18564 Check_Loop_Pragma_Placement
;
18566 -- Process all increasing / decreasing expressions
18568 Variant
:= First
(Pragma_Argument_Associations
(N
));
18569 while Present
(Variant
) loop
18570 if Chars
(Variant
) = No_Name
then
18571 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
18573 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
18577 Name
: String := Get_Name_String
(Chars
(Variant
));
18580 -- It is a common mistake to write "Increasing" for
18581 -- "Increases" or "Decreasing" for "Decreases". Recognize
18582 -- specially names starting with "incr" or "decr" to
18583 -- suggest the corresponding name.
18585 System
.Case_Util
.To_Lower
(Name
);
18587 if Name
'Length >= 4
18588 and then Name
(1 .. 4) = "incr"
18590 Error_Pragma_Arg_Ident
18591 ("expect name `Increases`", Variant
);
18593 elsif Name
'Length >= 4
18594 and then Name
(1 .. 4) = "decr"
18596 Error_Pragma_Arg_Ident
18597 ("expect name `Decreases`", Variant
);
18600 Error_Pragma_Arg_Ident
18601 ("expect name `Increases` or `Decreases`", Variant
);
18606 Preanalyze_Assert_Expression
18607 (Expression
(Variant
), Any_Discrete
);
18613 -----------------------
18614 -- Machine_Attribute --
18615 -----------------------
18617 -- pragma Machine_Attribute (
18618 -- [Entity =>] LOCAL_NAME,
18619 -- [Attribute_Name =>] static_string_EXPRESSION
18620 -- [, [Info =>] static_EXPRESSION] );
18622 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
18623 Def_Id
: Entity_Id
;
18627 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
18629 if Arg_Count
= 3 then
18630 Check_Optional_Identifier
(Arg3
, Name_Info
);
18631 Check_Arg_Is_OK_Static_Expression
(Arg3
);
18633 Check_Arg_Count
(2);
18636 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18637 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
18638 Check_Arg_Is_Local_Name
(Arg1
);
18639 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18640 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18642 if Is_Access_Type
(Def_Id
) then
18643 Def_Id
:= Designated_Type
(Def_Id
);
18646 if Rep_Item_Too_Early
(Def_Id
, N
) then
18650 Def_Id
:= Underlying_Type
(Def_Id
);
18652 -- The only processing required is to link this item on to the
18653 -- list of rep items for the given entity. This is accomplished
18654 -- by the call to Rep_Item_Too_Late (when no error is detected
18655 -- and False is returned).
18657 if Rep_Item_Too_Late
(Def_Id
, N
) then
18660 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18662 end Machine_Attribute
;
18669 -- (MAIN_OPTION [, MAIN_OPTION]);
18672 -- [STACK_SIZE =>] static_integer_EXPRESSION
18673 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
18674 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
18676 when Pragma_Main
=> Main
: declare
18677 Args
: Args_List
(1 .. 3);
18678 Names
: constant Name_List
(1 .. 3) := (
18680 Name_Task_Stack_Size_Default
,
18681 Name_Time_Slicing_Enabled
);
18687 Gather_Associations
(Names
, Args
);
18689 for J
in 1 .. 2 loop
18690 if Present
(Args
(J
)) then
18691 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18695 if Present
(Args
(3)) then
18696 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
18700 while Present
(Nod
) loop
18701 if Nkind
(Nod
) = N_Pragma
18702 and then Pragma_Name
(Nod
) = Name_Main
18704 Error_Msg_Name_1
:= Pname
;
18705 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18716 -- pragma Main_Storage
18717 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
18719 -- MAIN_STORAGE_OPTION ::=
18720 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
18721 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
18723 when Pragma_Main_Storage
=> Main_Storage
: declare
18724 Args
: Args_List
(1 .. 2);
18725 Names
: constant Name_List
(1 .. 2) := (
18726 Name_Working_Storage
,
18733 Gather_Associations
(Names
, Args
);
18735 for J
in 1 .. 2 loop
18736 if Present
(Args
(J
)) then
18737 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18741 Check_In_Main_Program
;
18744 while Present
(Nod
) loop
18745 if Nkind
(Nod
) = N_Pragma
18746 and then Pragma_Name
(Nod
) = Name_Main_Storage
18748 Error_Msg_Name_1
:= Pname
;
18749 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18756 ----------------------
18757 -- Max_Queue_Length --
18758 ----------------------
18760 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
18762 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
18764 Entry_Decl
: Node_Id
;
18765 Entry_Id
: Entity_Id
;
18770 Check_Arg_Count
(1);
18773 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
18775 -- Entry declaration
18777 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
18779 -- Entry illegally within a task
18781 if Nkind
(Parent
(N
)) = N_Task_Definition
then
18782 Error_Pragma
("pragma % cannot apply to task entries");
18786 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
18788 -- Otherwise the pragma is associated with an illegal construct
18791 Error_Pragma
("pragma % must apply to a protected entry");
18795 -- Mark the pragma as Ghost if the related subprogram is also
18796 -- Ghost. This also ensures that any expansion performed further
18797 -- below will produce Ghost nodes.
18799 Mark_Ghost_Pragma
(N
, Entry_Id
);
18801 -- Analyze the Integer expression
18803 Arg
:= Get_Pragma_Arg
(Arg1
);
18804 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
18806 Val
:= Expr_Value
(Arg
);
18810 ("argument for pragma% must be positive", Arg1
);
18812 elsif not UI_Is_In_Int_Range
(Val
) then
18814 ("argument for pragma% out of range of Integer", Arg1
);
18818 -- Manually substitute the expression value of the pragma argument
18819 -- if it's not an integer literal because this is not taken care
18820 -- of automatically elsewhere.
18822 if Nkind
(Arg
) /= N_Integer_Literal
then
18823 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
18826 Record_Rep_Item
(Entry_Id
, N
);
18827 end Max_Queue_Length
;
18833 -- pragma Memory_Size (NUMERIC_LITERAL)
18835 when Pragma_Memory_Size
=>
18838 -- Memory size is simply ignored
18840 Check_No_Identifiers
;
18841 Check_Arg_Count
(1);
18842 Check_Arg_Is_Integer_Literal
(Arg1
);
18850 -- The only correct use of this pragma is on its own in a file, in
18851 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18852 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18853 -- check for a file containing nothing but a No_Body pragma). If we
18854 -- attempt to process it during normal semantics processing, it means
18855 -- it was misplaced.
18857 when Pragma_No_Body
=>
18861 -----------------------------
18862 -- No_Elaboration_Code_All --
18863 -----------------------------
18865 -- pragma No_Elaboration_Code_All;
18867 when Pragma_No_Elaboration_Code_All
=>
18869 Check_Valid_Library_Unit_Pragma
;
18871 if Nkind
(N
) = N_Null_Statement
then
18875 -- Must appear for a spec or generic spec
18877 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18878 N_Generic_Package_Declaration
,
18879 N_Generic_Subprogram_Declaration
,
18880 N_Package_Declaration
,
18881 N_Subprogram_Declaration
)
18885 ("pragma% can only occur for package "
18886 & "or subprogram spec"));
18889 -- Set flag in unit table
18891 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18893 -- Set restriction No_Elaboration_Code if this is the main unit
18895 if Current_Sem_Unit
= Main_Unit
then
18896 Set_Restriction
(No_Elaboration_Code
, N
);
18899 -- If we are in the main unit or in an extended main source unit,
18900 -- then we also add it to the configuration restrictions so that
18901 -- it will apply to all units in the extended main source.
18903 if Current_Sem_Unit
= Main_Unit
18904 or else In_Extended_Main_Source_Unit
(N
)
18906 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18909 -- If in main extended unit, activate transitive with test
18911 if In_Extended_Main_Source_Unit
(N
) then
18912 Opt
.No_Elab_Code_All_Pragma
:= N
;
18915 -----------------------------
18916 -- No_Component_Reordering --
18917 -----------------------------
18919 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18921 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
18927 Check_At_Most_N_Arguments
(1);
18929 if Arg_Count
= 0 then
18930 Check_Valid_Configuration_Pragma
;
18931 Opt
.No_Component_Reordering
:= True;
18934 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18935 Check_Arg_Is_Local_Name
(Arg1
);
18936 E_Id
:= Get_Pragma_Arg
(Arg1
);
18938 if Etype
(E_Id
) = Any_Type
then
18942 E
:= Entity
(E_Id
);
18944 if not Is_Record_Type
(E
) then
18945 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
18948 Set_No_Reordering
(Base_Type
(E
));
18950 end No_Comp_Reordering
;
18952 --------------------------
18953 -- No_Heap_Finalization --
18954 --------------------------
18956 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18958 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18959 Context
: constant Node_Id
:= Parent
(N
);
18960 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18966 Check_No_Identifiers
;
18968 -- The pragma appears in a configuration file
18970 if No
(Context
) then
18971 Check_Arg_Count
(0);
18972 Check_Valid_Configuration_Pragma
;
18974 -- Detect a duplicate pragma
18976 if Present
(No_Heap_Finalization_Pragma
) then
18979 Prev
=> No_Heap_Finalization_Pragma
);
18983 No_Heap_Finalization_Pragma
:= N
;
18985 -- Otherwise the pragma should be associated with a library-level
18986 -- named access-to-object type.
18989 Check_Arg_Count
(1);
18990 Check_Arg_Is_Local_Name
(Arg1
);
18992 Find_Type
(Typ_Arg
);
18993 Typ
:= Entity
(Typ_Arg
);
18995 -- The type being subjected to the pragma is erroneous
18997 if Typ
= Any_Type
then
18998 Error_Pragma
("cannot find type referenced by pragma %");
19000 -- The pragma is applied to an incomplete or generic formal
19001 -- type way too early.
19003 elsif Rep_Item_Too_Early
(Typ
, N
) then
19007 Typ
:= Underlying_Type
(Typ
);
19010 -- The pragma must apply to an access-to-object type
19012 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
19015 -- Give a detailed error message on all other access type kinds
19017 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19019 ("pragma % cannot apply to access protected subprogram "
19022 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19024 ("pragma % cannot apply to access subprogram type");
19026 elsif Is_Anonymous_Access_Type
(Typ
) then
19028 ("pragma % cannot apply to anonymous access type");
19030 -- Give a general error message in case the pragma applies to a
19031 -- non-access type.
19035 ("pragma % must apply to library level access type");
19038 -- At this point the argument denotes an access-to-object type.
19039 -- Ensure that the type is declared at the library level.
19041 if Is_Library_Level_Entity
(Typ
) then
19044 -- Quietly ignore an access-to-object type originally declared
19045 -- at the library level within a generic, but instantiated at
19046 -- a non-library level. As a result the access-to-object type
19047 -- "loses" its No_Heap_Finalization property.
19049 elsif In_Instance
then
19054 ("pragma % must apply to library level access type");
19057 -- Detect a duplicate pragma
19059 if Present
(No_Heap_Finalization_Pragma
) then
19062 Prev
=> No_Heap_Finalization_Pragma
);
19066 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19068 if Present
(Prev
) then
19076 Record_Rep_Item
(Typ
, N
);
19078 end No_Heap_Finalization
;
19084 -- pragma No_Inline ( NAME {, NAME} );
19086 when Pragma_No_Inline
=>
19088 Process_Inline
(Suppressed
);
19094 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19096 when Pragma_No_Return
=> No_Return
: declare
19102 Ghost_Error_Posted
: Boolean := False;
19103 -- Flag set when an error concerning the illegal mix of Ghost and
19104 -- non-Ghost subprograms is emitted.
19106 Ghost_Id
: Entity_Id
:= Empty
;
19107 -- The entity of the first Ghost procedure encountered while
19108 -- processing the arguments of the pragma.
19112 Check_At_Least_N_Arguments
(1);
19114 -- Loop through arguments of pragma
19117 while Present
(Arg
) loop
19118 Check_Arg_Is_Local_Name
(Arg
);
19119 Id
:= Get_Pragma_Arg
(Arg
);
19122 if not Is_Entity_Name
(Id
) then
19123 Error_Pragma_Arg
("entity name required", Arg
);
19126 if Etype
(Id
) = Any_Type
then
19130 -- Loop to find matching procedures
19136 and then Scope
(E
) = Current_Scope
19138 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
19140 -- Check that the pragma is not applied to a body.
19141 -- First check the specless body case, to give a
19142 -- different error message. These checks do not apply
19143 -- if Relaxed_RM_Semantics, to accommodate other Ada
19144 -- compilers. Disable these checks under -gnatd.J.
19146 if not Debug_Flag_Dot_JJ
then
19147 if Nkind
(Parent
(Declaration_Node
(E
))) =
19149 and then not Relaxed_RM_Semantics
19152 ("pragma% requires separate spec and must come "
19156 -- Now the "specful" body case
19158 if Rep_Item_Too_Late
(E
, N
) then
19165 -- A pragma that applies to a Ghost entity becomes Ghost
19166 -- for the purposes of legality checks and removal of
19167 -- ignored Ghost code.
19169 Mark_Ghost_Pragma
(N
, E
);
19171 -- Capture the entity of the first Ghost procedure being
19172 -- processed for error detection purposes.
19174 if Is_Ghost_Entity
(E
) then
19175 if No
(Ghost_Id
) then
19179 -- Otherwise the subprogram is non-Ghost. It is illegal
19180 -- to mix references to Ghost and non-Ghost entities
19183 elsif Present
(Ghost_Id
)
19184 and then not Ghost_Error_Posted
19186 Ghost_Error_Posted
:= True;
19188 Error_Msg_Name_1
:= Pname
;
19190 ("pragma % cannot mention ghost and non-ghost "
19191 & "procedures", N
);
19193 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19194 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
19196 Error_Msg_Sloc
:= Sloc
(E
);
19197 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
19200 -- Set flag on any alias as well
19202 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
19203 Set_No_Return
(Alias
(E
));
19209 exit when From_Aspect_Specification
(N
);
19213 -- If entity in not in current scope it may be the enclosing
19214 -- suprogram body to which the aspect applies.
19217 if Entity
(Id
) = Current_Scope
19218 and then From_Aspect_Specification
(N
)
19220 Set_No_Return
(Entity
(Id
));
19222 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
19234 -- pragma No_Run_Time;
19236 -- Note: this pragma is retained for backwards compatibility. See
19237 -- body of Rtsfind for full details on its handling.
19239 when Pragma_No_Run_Time
=>
19241 Check_Valid_Configuration_Pragma
;
19242 Check_Arg_Count
(0);
19244 -- Remove backward compatibility if Build_Type is FSF or GPL and
19245 -- generate a warning.
19248 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
19251 Error_Pragma
("pragma% is ignored, has no effect??");
19253 No_Run_Time_Mode
:= True;
19254 Configurable_Run_Time_Mode
:= True;
19256 -- Set Duration to 32 bits if word size is 32
19258 if Ttypes
.System_Word_Size
= 32 then
19259 Duration_32_Bits_On_Target
:= True;
19262 -- Set appropriate restrictions
19264 Set_Restriction
(No_Finalization
, N
);
19265 Set_Restriction
(No_Exception_Handlers
, N
);
19266 Set_Restriction
(Max_Tasks
, N
, 0);
19267 Set_Restriction
(No_Tasking
, N
);
19271 -----------------------
19272 -- No_Tagged_Streams --
19273 -----------------------
19275 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
19277 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
19283 Check_At_Most_N_Arguments
(1);
19285 -- One argument case
19287 if Arg_Count
= 1 then
19288 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19289 Check_Arg_Is_Local_Name
(Arg1
);
19290 E_Id
:= Get_Pragma_Arg
(Arg1
);
19292 if Etype
(E_Id
) = Any_Type
then
19296 E
:= Entity
(E_Id
);
19298 Check_Duplicate_Pragma
(E
);
19300 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
19302 ("argument for pragma% must be root tagged type", Arg1
);
19305 if Rep_Item_Too_Early
(E
, N
)
19307 Rep_Item_Too_Late
(E
, N
)
19311 Set_No_Tagged_Streams_Pragma
(E
, N
);
19314 -- Zero argument case
19317 Check_Is_In_Decl_Part_Or_Package_Spec
;
19318 No_Tagged_Streams
:= N
;
19320 end No_Tagged_Strms
;
19322 ------------------------
19323 -- No_Strict_Aliasing --
19324 ------------------------
19326 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
19328 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
19334 Check_At_Most_N_Arguments
(1);
19336 if Arg_Count
= 0 then
19337 Check_Valid_Configuration_Pragma
;
19338 Opt
.No_Strict_Aliasing
:= True;
19341 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19342 Check_Arg_Is_Local_Name
(Arg1
);
19343 E_Id
:= Get_Pragma_Arg
(Arg1
);
19345 if Etype
(E_Id
) = Any_Type
then
19349 E
:= Entity
(E_Id
);
19351 if not Is_Access_Type
(E
) then
19352 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
19355 Set_No_Strict_Aliasing
(Base_Type
(E
));
19357 end No_Strict_Aliasing
;
19359 -----------------------
19360 -- Normalize_Scalars --
19361 -----------------------
19363 -- pragma Normalize_Scalars;
19365 when Pragma_Normalize_Scalars
=>
19366 Check_Ada_83_Warning
;
19367 Check_Arg_Count
(0);
19368 Check_Valid_Configuration_Pragma
;
19370 -- Normalize_Scalars creates false positives in CodePeer, and
19371 -- incorrect negative results in GNATprove mode, so ignore this
19372 -- pragma in these modes.
19374 if not (CodePeer_Mode
or GNATprove_Mode
) then
19375 Normalize_Scalars
:= True;
19376 Init_Or_Norm_Scalars
:= True;
19383 -- pragma Obsolescent;
19385 -- pragma Obsolescent (
19386 -- [Message =>] static_string_EXPRESSION
19387 -- [,[Version =>] Ada_05]]);
19389 -- pragma Obsolescent (
19390 -- [Entity =>] NAME
19391 -- [,[Message =>] static_string_EXPRESSION
19392 -- [,[Version =>] Ada_05]] );
19394 when Pragma_Obsolescent
=> Obsolescent
: declare
19398 procedure Set_Obsolescent
(E
: Entity_Id
);
19399 -- Given an entity Ent, mark it as obsolescent if appropriate
19401 ---------------------
19402 -- Set_Obsolescent --
19403 ---------------------
19405 procedure Set_Obsolescent
(E
: Entity_Id
) is
19414 -- A pragma that applies to a Ghost entity becomes Ghost for
19415 -- the purposes of legality checks and removal of ignored Ghost
19418 Mark_Ghost_Pragma
(N
, E
);
19420 -- Entity name was given
19422 if Present
(Ename
) then
19424 -- If entity name matches, we are fine. Save entity in
19425 -- pragma argument, for ASIS use.
19427 if Chars
(Ename
) = Chars
(Ent
) then
19428 Set_Entity
(Ename
, Ent
);
19429 Generate_Reference
(Ent
, Ename
);
19431 -- If entity name does not match, only possibility is an
19432 -- enumeration literal from an enumeration type declaration.
19434 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
19436 ("pragma % entity name does not match declaration");
19439 Ent
:= First_Literal
(E
);
19443 ("pragma % entity name does not match any "
19444 & "enumeration literal");
19446 elsif Chars
(Ent
) = Chars
(Ename
) then
19447 Set_Entity
(Ename
, Ent
);
19448 Generate_Reference
(Ent
, Ename
);
19452 Ent
:= Next_Literal
(Ent
);
19458 -- Ent points to entity to be marked
19460 if Arg_Count
>= 1 then
19462 -- Deal with static string argument
19464 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19465 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
19467 for J
in 1 .. String_Length
(S
) loop
19468 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
19470 ("pragma% argument does not allow wide characters",
19475 Obsolescent_Warnings
.Append
19476 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
19478 -- Check for Ada_05 parameter
19480 if Arg_Count
/= 1 then
19481 Check_Arg_Count
(2);
19484 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19487 Check_Arg_Is_Identifier
(Argx
);
19489 if Chars
(Argx
) /= Name_Ada_05
then
19490 Error_Msg_Name_2
:= Name_Ada_05
;
19492 ("only allowed argument for pragma% is %", Argx
);
19495 if Ada_Version_Explicit
< Ada_2005
19496 or else not Warn_On_Ada_2005_Compatibility
19504 -- Set flag if pragma active
19507 Set_Is_Obsolescent
(Ent
);
19511 end Set_Obsolescent
;
19513 -- Start of processing for pragma Obsolescent
19518 Check_At_Most_N_Arguments
(3);
19520 -- See if first argument specifies an entity name
19524 (Chars
(Arg1
) = Name_Entity
19526 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
19528 N_Operator_Symbol
))
19530 Ename
:= Get_Pragma_Arg
(Arg1
);
19532 -- Eliminate first argument, so we can share processing
19536 Arg_Count
:= Arg_Count
- 1;
19538 -- No Entity name argument given
19544 if Arg_Count
>= 1 then
19545 Check_Optional_Identifier
(Arg1
, Name_Message
);
19547 if Arg_Count
= 2 then
19548 Check_Optional_Identifier
(Arg2
, Name_Version
);
19552 -- Get immediately preceding declaration
19555 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
19559 -- Cases where we do not follow anything other than another pragma
19563 -- First case: library level compilation unit declaration with
19564 -- the pragma immediately following the declaration.
19566 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
19568 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
19571 -- Case 2: library unit placement for package
19575 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
19577 if Is_Package_Or_Generic_Package
(Ent
) then
19578 Set_Obsolescent
(Ent
);
19584 -- Cases where we must follow a declaration, including an
19585 -- abstract subprogram declaration, which is not in the
19586 -- other node subtypes.
19589 if Nkind
(Decl
) not in N_Declaration
19590 and then Nkind
(Decl
) not in N_Later_Decl_Item
19591 and then Nkind
(Decl
) not in N_Generic_Declaration
19592 and then Nkind
(Decl
) not in N_Renaming_Declaration
19593 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
19596 ("pragma% misplaced, "
19597 & "must immediately follow a declaration");
19600 Set_Obsolescent
(Defining_Entity
(Decl
));
19610 -- pragma Optimize (Time | Space | Off);
19612 -- The actual check for optimize is done in Gigi. Note that this
19613 -- pragma does not actually change the optimization setting, it
19614 -- simply checks that it is consistent with the pragma.
19616 when Pragma_Optimize
=>
19617 Check_No_Identifiers
;
19618 Check_Arg_Count
(1);
19619 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
19621 ------------------------
19622 -- Optimize_Alignment --
19623 ------------------------
19625 -- pragma Optimize_Alignment (Time | Space | Off);
19627 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
19629 Check_No_Identifiers
;
19630 Check_Arg_Count
(1);
19631 Check_Valid_Configuration_Pragma
;
19634 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
19637 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
19638 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
19639 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
19642 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
19646 -- Set indication that mode is set locally. If we are in fact in a
19647 -- configuration pragma file, this setting is harmless since the
19648 -- switch will get reset anyway at the start of each unit.
19650 Optimize_Alignment_Local
:= True;
19651 end Optimize_Alignment
;
19657 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
19659 when Pragma_Ordered
=> Ordered
: declare
19660 Assoc
: constant Node_Id
:= Arg1
;
19666 Check_No_Identifiers
;
19667 Check_Arg_Count
(1);
19668 Check_Arg_Is_Local_Name
(Arg1
);
19670 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19671 Find_Type
(Type_Id
);
19672 Typ
:= Entity
(Type_Id
);
19674 if Typ
= Any_Type
then
19677 Typ
:= Underlying_Type
(Typ
);
19680 if not Is_Enumeration_Type
(Typ
) then
19681 Error_Pragma
("pragma% must specify enumeration type");
19684 Check_First_Subtype
(Arg1
);
19685 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
19688 -------------------
19689 -- Overflow_Mode --
19690 -------------------
19692 -- pragma Overflow_Mode
19693 -- ([General => ] MODE [, [Assertions => ] MODE]);
19695 -- MODE := STRICT | MINIMIZED | ELIMINATED
19697 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
19698 -- since System.Bignums makes this assumption. This is true of nearly
19699 -- all (all?) targets.
19701 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
19702 function Get_Overflow_Mode
19704 Arg
: Node_Id
) return Overflow_Mode_Type
;
19705 -- Function to process one pragma argument, Arg. If an identifier
19706 -- is present, it must be Name. Mode type is returned if a valid
19707 -- argument exists, otherwise an error is signalled.
19709 -----------------------
19710 -- Get_Overflow_Mode --
19711 -----------------------
19713 function Get_Overflow_Mode
19715 Arg
: Node_Id
) return Overflow_Mode_Type
19717 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
19720 Check_Optional_Identifier
(Arg
, Name
);
19721 Check_Arg_Is_Identifier
(Argx
);
19723 if Chars
(Argx
) = Name_Strict
then
19726 elsif Chars
(Argx
) = Name_Minimized
then
19729 elsif Chars
(Argx
) = Name_Eliminated
then
19730 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
19732 ("Eliminated not implemented on this target", Argx
);
19738 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
19740 end Get_Overflow_Mode
;
19742 -- Start of processing for Overflow_Mode
19746 Check_At_Least_N_Arguments
(1);
19747 Check_At_Most_N_Arguments
(2);
19749 -- Process first argument
19751 Scope_Suppress
.Overflow_Mode_General
:=
19752 Get_Overflow_Mode
(Name_General
, Arg1
);
19754 -- Case of only one argument
19756 if Arg_Count
= 1 then
19757 Scope_Suppress
.Overflow_Mode_Assertions
:=
19758 Scope_Suppress
.Overflow_Mode_General
;
19760 -- Case of two arguments present
19763 Scope_Suppress
.Overflow_Mode_Assertions
:=
19764 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
19768 --------------------------
19769 -- Overriding Renamings --
19770 --------------------------
19772 -- pragma Overriding_Renamings;
19774 when Pragma_Overriding_Renamings
=>
19776 Check_Arg_Count
(0);
19777 Check_Valid_Configuration_Pragma
;
19778 Overriding_Renamings
:= True;
19784 -- pragma Pack (first_subtype_LOCAL_NAME);
19786 when Pragma_Pack
=> Pack
: declare
19787 Assoc
: constant Node_Id
:= Arg1
;
19789 Ignore
: Boolean := False;
19794 Check_No_Identifiers
;
19795 Check_Arg_Count
(1);
19796 Check_Arg_Is_Local_Name
(Arg1
);
19797 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19799 if not Is_Entity_Name
(Type_Id
)
19800 or else not Is_Type
(Entity
(Type_Id
))
19803 ("argument for pragma% must be type or subtype", Arg1
);
19806 Find_Type
(Type_Id
);
19807 Typ
:= Entity
(Type_Id
);
19810 or else Rep_Item_Too_Early
(Typ
, N
)
19814 Typ
:= Underlying_Type
(Typ
);
19817 -- A pragma that applies to a Ghost entity becomes Ghost for the
19818 -- purposes of legality checks and removal of ignored Ghost code.
19820 Mark_Ghost_Pragma
(N
, Typ
);
19822 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
19823 Error_Pragma
("pragma% must specify array or record type");
19826 Check_First_Subtype
(Arg1
);
19827 Check_Duplicate_Pragma
(Typ
);
19831 if Is_Array_Type
(Typ
) then
19832 Ctyp
:= Component_Type
(Typ
);
19834 -- Ignore pack that does nothing
19836 if Known_Static_Esize
(Ctyp
)
19837 and then Known_Static_RM_Size
(Ctyp
)
19838 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
19839 and then Addressable
(Esize
(Ctyp
))
19844 -- Process OK pragma Pack. Note that if there is a separate
19845 -- component clause present, the Pack will be cancelled. This
19846 -- processing is in Freeze.
19848 if not Rep_Item_Too_Late
(Typ
, N
) then
19850 -- In CodePeer mode, we do not need complex front-end
19851 -- expansions related to pragma Pack, so disable handling
19854 if CodePeer_Mode
then
19857 -- Normal case where we do the pack action
19861 Set_Is_Packed
(Base_Type
(Typ
));
19862 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19865 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19869 -- For record types, the pack is always effective
19871 else pragma Assert
(Is_Record_Type
(Typ
));
19872 if not Rep_Item_Too_Late
(Typ
, N
) then
19873 Set_Is_Packed
(Base_Type
(Typ
));
19874 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19875 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19886 -- There is nothing to do here, since we did all the processing for
19887 -- this pragma in Par.Prag (so that it works properly even in syntax
19890 when Pragma_Page
=>
19897 -- pragma Part_Of (ABSTRACT_STATE);
19899 -- ABSTRACT_STATE ::= NAME
19901 when Pragma_Part_Of
=> Part_Of
: declare
19902 procedure Propagate_Part_Of
19903 (Pack_Id
: Entity_Id
;
19904 State_Id
: Entity_Id
;
19905 Instance
: Node_Id
);
19906 -- Propagate the Part_Of indicator to all abstract states and
19907 -- objects declared in the visible state space of a package
19908 -- denoted by Pack_Id. State_Id is the encapsulating state.
19909 -- Instance is the package instantiation node.
19911 -----------------------
19912 -- Propagate_Part_Of --
19913 -----------------------
19915 procedure Propagate_Part_Of
19916 (Pack_Id
: Entity_Id
;
19917 State_Id
: Entity_Id
;
19918 Instance
: Node_Id
)
19920 Has_Item
: Boolean := False;
19921 -- Flag set when the visible state space contains at least one
19922 -- abstract state or variable.
19924 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19925 -- Propagate the Part_Of indicator to all abstract states and
19926 -- objects declared in the visible state space of a package
19927 -- denoted by Pack_Id.
19929 -----------------------
19930 -- Propagate_Part_Of --
19931 -----------------------
19933 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19934 Constits
: Elist_Id
;
19935 Item_Id
: Entity_Id
;
19938 -- Traverse the entity chain of the package and set relevant
19939 -- attributes of abstract states and objects declared in the
19940 -- visible state space of the package.
19942 Item_Id
:= First_Entity
(Pack_Id
);
19943 while Present
(Item_Id
)
19944 and then not In_Private_Part
(Item_Id
)
19946 -- Do not consider internally generated items
19948 if not Comes_From_Source
(Item_Id
) then
19951 -- The Part_Of indicator turns an abstract state or an
19952 -- object into a constituent of the encapsulating state.
19954 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19959 Constits
:= Part_Of_Constituents
(State_Id
);
19961 if No
(Constits
) then
19962 Constits
:= New_Elmt_List
;
19963 Set_Part_Of_Constituents
(State_Id
, Constits
);
19966 Append_Elmt
(Item_Id
, Constits
);
19967 Set_Encapsulating_State
(Item_Id
, State_Id
);
19969 -- Recursively handle nested packages and instantiations
19971 elsif Ekind
(Item_Id
) = E_Package
then
19972 Propagate_Part_Of
(Item_Id
);
19975 Next_Entity
(Item_Id
);
19977 end Propagate_Part_Of
;
19979 -- Start of processing for Propagate_Part_Of
19982 Propagate_Part_Of
(Pack_Id
);
19984 -- Detect a package instantiation that is subject to a Part_Of
19985 -- indicator, but has no visible state.
19987 if not Has_Item
then
19989 ("package instantiation & has Part_Of indicator but "
19990 & "lacks visible state", Instance
, Pack_Id
);
19992 end Propagate_Part_Of
;
19996 Constits
: Elist_Id
;
19998 Encap_Id
: Entity_Id
;
19999 Item_Id
: Entity_Id
;
20003 -- Start of processing for Part_Of
20007 Check_No_Identifiers
;
20008 Check_Arg_Count
(1);
20010 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
20012 -- Object declaration
20014 if Nkind
(Stmt
) = N_Object_Declaration
then
20017 -- Package instantiation
20019 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
20022 -- Single concurrent type declaration
20024 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
20027 -- Otherwise the pragma is associated with an illegal construct
20034 -- Extract the entity of the related object declaration or package
20035 -- instantiation. In the case of the instantiation, use the entity
20036 -- of the instance spec.
20038 if Nkind
(Stmt
) = N_Package_Instantiation
then
20039 Stmt
:= Instance_Spec
(Stmt
);
20042 Item_Id
:= Defining_Entity
(Stmt
);
20044 -- A pragma that applies to a Ghost entity becomes Ghost for the
20045 -- purposes of legality checks and removal of ignored Ghost code.
20047 Mark_Ghost_Pragma
(N
, Item_Id
);
20049 -- Chain the pragma on the contract for further processing by
20050 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20052 Add_Contract_Item
(N
, Item_Id
);
20054 -- A variable may act as constituent of a single concurrent type
20055 -- which in turn could be declared after the variable. Due to this
20056 -- discrepancy, the full analysis of indicator Part_Of is delayed
20057 -- until the end of the enclosing declarative region (see routine
20058 -- Analyze_Part_Of_In_Decl_Part).
20060 if Ekind
(Item_Id
) = E_Variable
then
20063 -- Otherwise indicator Part_Of applies to a constant or a package
20067 Encap
:= Get_Pragma_Arg
(Arg1
);
20069 -- Detect any discrepancies between the placement of the
20070 -- constant or package instantiation with respect to state
20071 -- space and the encapsulating state.
20075 Item_Id
=> Item_Id
,
20077 Encap_Id
=> Encap_Id
,
20081 pragma Assert
(Present
(Encap_Id
));
20083 if Ekind
(Item_Id
) = E_Constant
then
20084 Constits
:= Part_Of_Constituents
(Encap_Id
);
20086 if No
(Constits
) then
20087 Constits
:= New_Elmt_List
;
20088 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
20091 Append_Elmt
(Item_Id
, Constits
);
20092 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
20094 -- Propagate the Part_Of indicator to the visible state
20095 -- space of the package instantiation.
20099 (Pack_Id
=> Item_Id
,
20100 State_Id
=> Encap_Id
,
20107 ----------------------------------
20108 -- Partition_Elaboration_Policy --
20109 ----------------------------------
20111 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20113 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
20114 subtype PEP_Range
is Name_Id
20115 range First_Partition_Elaboration_Policy_Name
20116 .. Last_Partition_Elaboration_Policy_Name
;
20117 PEP_Val
: PEP_Range
;
20122 Check_Arg_Count
(1);
20123 Check_No_Identifiers
;
20124 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
20125 Check_Valid_Configuration_Pragma
;
20126 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20129 when Name_Concurrent
=> PEP
:= 'C';
20130 when Name_Sequential
=> PEP
:= 'S';
20133 if Partition_Elaboration_Policy
/= ' '
20134 and then Partition_Elaboration_Policy
/= PEP
20136 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
20138 ("partition elaboration policy incompatible with policy#");
20140 -- Set new policy, but always preserve System_Location since we
20141 -- like the error message with the run time name.
20144 Partition_Elaboration_Policy
:= PEP
;
20146 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
20147 Partition_Elaboration_Policy_Sloc
:= Loc
;
20156 -- pragma Passive [(PASSIVE_FORM)];
20158 -- PASSIVE_FORM ::= Semaphore | No
20160 when Pragma_Passive
=>
20163 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
20164 Error_Pragma
("pragma% must be within task definition");
20167 if Arg_Count
/= 0 then
20168 Check_Arg_Count
(1);
20169 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
20172 ----------------------------------
20173 -- Preelaborable_Initialization --
20174 ----------------------------------
20176 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20178 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
20183 Check_Arg_Count
(1);
20184 Check_No_Identifiers
;
20185 Check_Arg_Is_Identifier
(Arg1
);
20186 Check_Arg_Is_Local_Name
(Arg1
);
20187 Check_First_Subtype
(Arg1
);
20188 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20190 -- A pragma that applies to a Ghost entity becomes Ghost for the
20191 -- purposes of legality checks and removal of ignored Ghost code.
20193 Mark_Ghost_Pragma
(N
, Ent
);
20195 -- The pragma may come from an aspect on a private declaration,
20196 -- even if the freeze point at which this is analyzed in the
20197 -- private part after the full view.
20199 if Has_Private_Declaration
(Ent
)
20200 and then From_Aspect_Specification
(N
)
20204 -- Check appropriate type argument
20206 elsif Is_Private_Type
(Ent
)
20207 or else Is_Protected_Type
(Ent
)
20208 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
20210 -- AI05-0028: The pragma applies to all composite types. Note
20211 -- that we apply this binding interpretation to earlier versions
20212 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20213 -- choice since there are other compilers that do the same.
20215 or else Is_Composite_Type
(Ent
)
20221 ("pragma % can only be applied to private, formal derived, "
20222 & "protected, or composite type", Arg1
);
20225 -- Give an error if the pragma is applied to a protected type that
20226 -- does not qualify (due to having entries, or due to components
20227 -- that do not qualify).
20229 if Is_Protected_Type
(Ent
)
20230 and then not Has_Preelaborable_Initialization
(Ent
)
20233 ("protected type & does not have preelaborable "
20234 & "initialization", Ent
);
20236 -- Otherwise mark the type as definitely having preelaborable
20240 Set_Known_To_Have_Preelab_Init
(Ent
);
20243 if Has_Pragma_Preelab_Init
(Ent
)
20244 and then Warn_On_Redundant_Constructs
20246 Error_Pragma
("?r?duplicate pragma%!");
20248 Set_Has_Pragma_Preelab_Init
(Ent
);
20252 --------------------
20253 -- Persistent_BSS --
20254 --------------------
20256 -- pragma Persistent_BSS [(object_NAME)];
20258 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
20265 Check_At_Most_N_Arguments
(1);
20267 -- Case of application to specific object (one argument)
20269 if Arg_Count
= 1 then
20270 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20272 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
20274 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
20277 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
20280 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20282 -- A pragma that applies to a Ghost entity becomes Ghost for
20283 -- the purposes of legality checks and removal of ignored Ghost
20286 Mark_Ghost_Pragma
(N
, Ent
);
20288 -- Check for duplication before inserting in list of
20289 -- representation items.
20291 Check_Duplicate_Pragma
(Ent
);
20293 if Rep_Item_Too_Late
(Ent
, N
) then
20297 Decl
:= Parent
(Ent
);
20299 if Present
(Expression
(Decl
)) then
20301 ("object for pragma% cannot have initialization", Arg1
);
20304 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
20306 ("object type for pragma% is not potentially persistent",
20311 Make_Linker_Section_Pragma
20312 (Ent
, Sloc
(N
), ".persistent.bss");
20313 Insert_After
(N
, Prag
);
20316 -- Case of use as configuration pragma with no arguments
20319 Check_Valid_Configuration_Pragma
;
20320 Persistent_BSS_Mode
:= True;
20322 end Persistent_BSS
;
20324 --------------------
20325 -- Rename_Pragma --
20326 --------------------
20328 -- pragma Rename_Pragma (
20329 -- [New_Name =>] IDENTIFIER,
20330 -- [Renamed =>] pragma_IDENTIFIER);
20332 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
20333 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20334 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20338 Check_Valid_Configuration_Pragma
;
20339 Check_Arg_Count
(2);
20340 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
20341 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
20343 if Nkind
(New_Name
) /= N_Identifier
then
20344 Error_Pragma_Arg
("identifier expected", Arg1
);
20347 if Nkind
(Old_Name
) /= N_Identifier
then
20348 Error_Pragma_Arg
("identifier expected", Arg2
);
20351 -- The New_Name arg should not be an existing pragma (but we allow
20352 -- it; it's just a warning). The Old_Name arg must be an existing
20355 if Is_Pragma_Name
(Chars
(New_Name
)) then
20356 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
20359 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
20360 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
20363 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
20370 -- pragma Polling (ON | OFF);
20372 when Pragma_Polling
=>
20374 Check_Arg_Count
(1);
20375 Check_No_Identifiers
;
20376 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20377 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
20379 -----------------------------------
20380 -- Post/Post_Class/Postcondition --
20381 -----------------------------------
20383 -- pragma Post (Boolean_EXPRESSION);
20384 -- pragma Post_Class (Boolean_EXPRESSION);
20385 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20386 -- [,[Message =>] String_EXPRESSION]);
20388 -- Characteristics:
20390 -- * Analysis - The annotation undergoes initial checks to verify
20391 -- the legal placement and context. Secondary checks preanalyze the
20394 -- Analyze_Pre_Post_Condition_In_Decl_Part
20396 -- * Expansion - The annotation is expanded during the expansion of
20397 -- the related subprogram [body] contract as performed in:
20399 -- Expand_Subprogram_Contract
20401 -- * Template - The annotation utilizes the generic template of the
20402 -- related subprogram [body] when it is:
20404 -- aspect on subprogram declaration
20405 -- aspect on stand-alone subprogram body
20406 -- pragma on stand-alone subprogram body
20408 -- The annotation must prepare its own template when it is:
20410 -- pragma on subprogram declaration
20412 -- * Globals - Capture of global references must occur after full
20415 -- * Instance - The annotation is instantiated automatically when
20416 -- the related generic subprogram [body] is instantiated except for
20417 -- the "pragma on subprogram declaration" case. In that scenario
20418 -- the annotation must instantiate itself.
20421 | Pragma_Post_Class
20422 | Pragma_Postcondition
20424 Analyze_Pre_Post_Condition
;
20426 --------------------------------
20427 -- Pre/Pre_Class/Precondition --
20428 --------------------------------
20430 -- pragma Pre (Boolean_EXPRESSION);
20431 -- pragma Pre_Class (Boolean_EXPRESSION);
20432 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20433 -- [,[Message =>] String_EXPRESSION]);
20435 -- Characteristics:
20437 -- * Analysis - The annotation undergoes initial checks to verify
20438 -- the legal placement and context. Secondary checks preanalyze the
20441 -- Analyze_Pre_Post_Condition_In_Decl_Part
20443 -- * Expansion - The annotation is expanded during the expansion of
20444 -- the related subprogram [body] contract as performed in:
20446 -- Expand_Subprogram_Contract
20448 -- * Template - The annotation utilizes the generic template of the
20449 -- related subprogram [body] when it is:
20451 -- aspect on subprogram declaration
20452 -- aspect on stand-alone subprogram body
20453 -- pragma on stand-alone subprogram body
20455 -- The annotation must prepare its own template when it is:
20457 -- pragma on subprogram declaration
20459 -- * Globals - Capture of global references must occur after full
20462 -- * Instance - The annotation is instantiated automatically when
20463 -- the related generic subprogram [body] is instantiated except for
20464 -- the "pragma on subprogram declaration" case. In that scenario
20465 -- the annotation must instantiate itself.
20469 | Pragma_Precondition
20471 Analyze_Pre_Post_Condition
;
20477 -- pragma Predicate
20478 -- ([Entity =>] type_LOCAL_NAME,
20479 -- [Check =>] boolean_EXPRESSION);
20481 when Pragma_Predicate
=> Predicate
: declare
20488 Check_Arg_Count
(2);
20489 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20490 Check_Optional_Identifier
(Arg2
, Name_Check
);
20492 Check_Arg_Is_Local_Name
(Arg1
);
20494 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20495 Find_Type
(Type_Id
);
20496 Typ
:= Entity
(Type_Id
);
20498 if Typ
= Any_Type
then
20502 -- A pragma that applies to a Ghost entity becomes Ghost for the
20503 -- purposes of legality checks and removal of ignored Ghost code.
20505 Mark_Ghost_Pragma
(N
, Typ
);
20507 -- The remaining processing is simply to link the pragma on to
20508 -- the rep item chain, for processing when the type is frozen.
20509 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20510 -- mark the type as having predicates.
20512 -- If the current policy for predicate checking is Ignore mark the
20513 -- subtype accordingly. In the case of predicates we consider them
20514 -- enabled unless Ignore is specified (either directly or with a
20515 -- general Assertion_Policy pragma) to preserve existing warnings.
20517 Set_Has_Predicates
(Typ
);
20519 -- Indicate that the pragma must be processed at the point the
20520 -- type is frozen, as is done for the corresponding aspect.
20522 Set_Has_Delayed_Aspects
(Typ
);
20523 Set_Has_Delayed_Freeze
(Typ
);
20525 Set_Predicates_Ignored
(Typ
,
20526 Present
(Check_Policy_List
)
20528 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
20529 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20532 -----------------------
20533 -- Predicate_Failure --
20534 -----------------------
20536 -- pragma Predicate_Failure
20537 -- ([Entity =>] type_LOCAL_NAME,
20538 -- [Message =>] string_EXPRESSION);
20540 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
20547 Check_Arg_Count
(2);
20548 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20549 Check_Optional_Identifier
(Arg2
, Name_Message
);
20551 Check_Arg_Is_Local_Name
(Arg1
);
20553 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20554 Find_Type
(Type_Id
);
20555 Typ
:= Entity
(Type_Id
);
20557 if Typ
= Any_Type
then
20561 -- A pragma that applies to a Ghost entity becomes Ghost for the
20562 -- purposes of legality checks and removal of ignored Ghost code.
20564 Mark_Ghost_Pragma
(N
, Typ
);
20566 -- The remaining processing is simply to link the pragma on to
20567 -- the rep item chain, for processing when the type is frozen.
20568 -- This is accomplished by a call to Rep_Item_Too_Late.
20570 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20571 end Predicate_Failure
;
20577 -- pragma Preelaborate [(library_unit_NAME)];
20579 -- Set the flag Is_Preelaborated of program unit name entity
20581 when Pragma_Preelaborate
=> Preelaborate
: declare
20582 Pa
: constant Node_Id
:= Parent
(N
);
20583 Pk
: constant Node_Kind
:= Nkind
(Pa
);
20587 Check_Ada_83_Warning
;
20588 Check_Valid_Library_Unit_Pragma
;
20590 if Nkind
(N
) = N_Null_Statement
then
20594 Ent
:= Find_Lib_Unit_Name
;
20596 -- A pragma that applies to a Ghost entity becomes Ghost for the
20597 -- purposes of legality checks and removal of ignored Ghost code.
20599 Mark_Ghost_Pragma
(N
, Ent
);
20600 Check_Duplicate_Pragma
(Ent
);
20602 -- This filters out pragmas inside generic parents that show up
20603 -- inside instantiations. Pragmas that come from aspects in the
20604 -- unit are not ignored.
20606 if Present
(Ent
) then
20607 if Pk
= N_Package_Specification
20608 and then Present
(Generic_Parent
(Pa
))
20609 and then not From_Aspect_Specification
(N
)
20614 if not Debug_Flag_U
then
20615 Set_Is_Preelaborated
(Ent
);
20617 if Legacy_Elaboration_Checks
then
20618 Set_Suppress_Elaboration_Warnings
(Ent
);
20625 -------------------------------
20626 -- Prefix_Exception_Messages --
20627 -------------------------------
20629 -- pragma Prefix_Exception_Messages;
20631 when Pragma_Prefix_Exception_Messages
=>
20633 Check_Valid_Configuration_Pragma
;
20634 Check_Arg_Count
(0);
20635 Prefix_Exception_Messages
:= True;
20641 -- pragma Priority (EXPRESSION);
20643 when Pragma_Priority
=> Priority
: declare
20644 P
: constant Node_Id
:= Parent
(N
);
20649 Check_No_Identifiers
;
20650 Check_Arg_Count
(1);
20654 if Nkind
(P
) = N_Subprogram_Body
then
20655 Check_In_Main_Program
;
20657 Ent
:= Defining_Unit_Name
(Specification
(P
));
20659 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
20660 Ent
:= Defining_Identifier
(Ent
);
20663 Arg
:= Get_Pragma_Arg
(Arg1
);
20664 Analyze_And_Resolve
(Arg
, Standard_Integer
);
20668 if not Is_OK_Static_Expression
(Arg
) then
20669 Flag_Non_Static_Expr
20670 ("main subprogram priority is not static!", Arg
);
20673 -- If constraint error, then we already signalled an error
20675 elsif Raises_Constraint_Error
(Arg
) then
20678 -- Otherwise check in range except if Relaxed_RM_Semantics
20679 -- where we ignore the value if out of range.
20682 if not Relaxed_RM_Semantics
20683 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
20686 ("main subprogram priority is out of range", Arg1
);
20689 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
20693 -- Load an arbitrary entity from System.Tasking.Stages or
20694 -- System.Tasking.Restricted.Stages (depending on the
20695 -- supported profile) to make sure that one of these packages
20696 -- is implicitly with'ed, since we need to have the tasking
20697 -- run time active for the pragma Priority to have any effect.
20698 -- Previously we with'ed the package System.Tasking, but this
20699 -- package does not trigger the required initialization of the
20700 -- run-time library.
20703 Discard
: Entity_Id
;
20704 pragma Warnings
(Off
, Discard
);
20706 if Restricted_Profile
then
20707 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
20709 Discard
:= RTE
(RE_Activate_Tasks
);
20713 -- Task or Protected, must be of type Integer
20715 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
20716 Arg
:= Get_Pragma_Arg
(Arg1
);
20717 Ent
:= Defining_Identifier
(Parent
(P
));
20719 -- The expression must be analyzed in the special manner
20720 -- described in "Handling of Default and Per-Object
20721 -- Expressions" in sem.ads.
20723 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
20725 if not Is_OK_Static_Expression
(Arg
) then
20726 Check_Restriction
(Static_Priorities
, Arg
);
20729 -- Anything else is incorrect
20735 -- Check duplicate pragma before we chain the pragma in the Rep
20736 -- Item chain of Ent.
20738 Check_Duplicate_Pragma
(Ent
);
20739 Record_Rep_Item
(Ent
, N
);
20742 -----------------------------------
20743 -- Priority_Specific_Dispatching --
20744 -----------------------------------
20746 -- pragma Priority_Specific_Dispatching (
20747 -- policy_IDENTIFIER,
20748 -- first_priority_EXPRESSION,
20749 -- last_priority_EXPRESSION);
20751 when Pragma_Priority_Specific_Dispatching
=>
20752 Priority_Specific_Dispatching
: declare
20753 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
20754 -- This is the entity System.Any_Priority;
20757 Lower_Bound
: Node_Id
;
20758 Upper_Bound
: Node_Id
;
20764 Check_Arg_Count
(3);
20765 Check_No_Identifiers
;
20766 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20767 Check_Valid_Configuration_Pragma
;
20768 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20769 DP
:= Fold_Upper
(Name_Buffer
(1));
20771 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
20772 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
20773 Lower_Val
:= Expr_Value
(Lower_Bound
);
20775 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
20776 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
20777 Upper_Val
:= Expr_Value
(Upper_Bound
);
20779 -- It is not allowed to use Task_Dispatching_Policy and
20780 -- Priority_Specific_Dispatching in the same partition.
20782 if Task_Dispatching_Policy
/= ' ' then
20783 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20785 ("pragma% incompatible with Task_Dispatching_Policy#");
20787 -- Check lower bound in range
20789 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20791 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20794 ("first_priority is out of range", Arg2
);
20796 -- Check upper bound in range
20798 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20800 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20803 ("last_priority is out of range", Arg3
);
20805 -- Check that the priority range is valid
20807 elsif Lower_Val
> Upper_Val
then
20809 ("last_priority_expression must be greater than or equal to "
20810 & "first_priority_expression");
20812 -- Store the new policy, but always preserve System_Location since
20813 -- we like the error message with the run-time name.
20816 -- Check overlapping in the priority ranges specified in other
20817 -- Priority_Specific_Dispatching pragmas within the same
20818 -- partition. We can only check those we know about.
20821 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
20823 if Specific_Dispatching
.Table
(J
).First_Priority
in
20824 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20825 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
20826 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20829 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
20831 ("priority range overlaps with "
20832 & "Priority_Specific_Dispatching#");
20836 -- The use of Priority_Specific_Dispatching is incompatible
20837 -- with Task_Dispatching_Policy.
20839 if Task_Dispatching_Policy
/= ' ' then
20840 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20842 ("Priority_Specific_Dispatching incompatible "
20843 & "with Task_Dispatching_Policy#");
20846 -- The use of Priority_Specific_Dispatching forces ceiling
20849 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
20850 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20852 ("Priority_Specific_Dispatching incompatible "
20853 & "with Locking_Policy#");
20855 -- Set the Ceiling_Locking policy, but preserve System_Location
20856 -- since we like the error message with the run time name.
20859 Locking_Policy
:= 'C';
20861 if Locking_Policy_Sloc
/= System_Location
then
20862 Locking_Policy_Sloc
:= Loc
;
20866 -- Add entry in the table
20868 Specific_Dispatching
.Append
20869 ((Dispatching_Policy
=> DP
,
20870 First_Priority
=> UI_To_Int
(Lower_Val
),
20871 Last_Priority
=> UI_To_Int
(Upper_Val
),
20872 Pragma_Loc
=> Loc
));
20874 end Priority_Specific_Dispatching
;
20880 -- pragma Profile (profile_IDENTIFIER);
20882 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20884 when Pragma_Profile
=>
20886 Check_Arg_Count
(1);
20887 Check_Valid_Configuration_Pragma
;
20888 Check_No_Identifiers
;
20891 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20894 if Chars
(Argx
) = Name_Ravenscar
then
20895 Set_Ravenscar_Profile
(Ravenscar
, N
);
20897 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
20898 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
20900 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
20901 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
20903 elsif Chars
(Argx
) = Name_Restricted
then
20904 Set_Profile_Restrictions
20906 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20908 elsif Chars
(Argx
) = Name_Rational
then
20909 Set_Rational_Profile
;
20911 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20912 Set_Profile_Restrictions
20913 (No_Implementation_Extensions
,
20914 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20917 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20921 ----------------------
20922 -- Profile_Warnings --
20923 ----------------------
20925 -- pragma Profile_Warnings (profile_IDENTIFIER);
20927 -- profile_IDENTIFIER => Restricted | Ravenscar
20929 when Pragma_Profile_Warnings
=>
20931 Check_Arg_Count
(1);
20932 Check_Valid_Configuration_Pragma
;
20933 Check_No_Identifiers
;
20936 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20939 if Chars
(Argx
) = Name_Ravenscar
then
20940 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20942 elsif Chars
(Argx
) = Name_Restricted
then
20943 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20945 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20946 Set_Profile_Restrictions
20947 (No_Implementation_Extensions
, N
, Warn
=> True);
20950 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20954 --------------------------
20955 -- Propagate_Exceptions --
20956 --------------------------
20958 -- pragma Propagate_Exceptions;
20960 -- Note: this pragma is obsolete and has no effect
20962 when Pragma_Propagate_Exceptions
=>
20964 Check_Arg_Count
(0);
20966 if Warn_On_Obsolescent_Feature
then
20968 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20969 "and has no effect?j?", N
);
20972 -----------------------------
20973 -- Provide_Shift_Operators --
20974 -----------------------------
20976 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20978 when Pragma_Provide_Shift_Operators
=>
20979 Provide_Shift_Operators
: declare
20982 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
20983 -- Insert declaration and pragma Instrinsic for named shift op
20985 ----------------------------
20986 -- Declare_Shift_Operator --
20987 ----------------------------
20989 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
20995 Make_Subprogram_Declaration
(Loc
,
20996 Make_Function_Specification
(Loc
,
20997 Defining_Unit_Name
=>
20998 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
21000 Result_Definition
=>
21001 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
21003 Parameter_Specifications
=> New_List
(
21004 Make_Parameter_Specification
(Loc
,
21005 Defining_Identifier
=>
21006 Make_Defining_Identifier
(Loc
, Name_Value
),
21008 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
21010 Make_Parameter_Specification
(Loc
,
21011 Defining_Identifier
=>
21012 Make_Defining_Identifier
(Loc
, Name_Amount
),
21014 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
21018 Chars
=> Name_Import
,
21019 Pragma_Argument_Associations
=> New_List
(
21020 Make_Pragma_Argument_Association
(Loc
,
21021 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
21022 Make_Pragma_Argument_Association
(Loc
,
21023 Expression
=> Make_Identifier
(Loc
, Nam
))));
21025 Insert_After
(N
, Import
);
21026 Insert_After
(N
, Func
);
21027 end Declare_Shift_Operator
;
21029 -- Start of processing for Provide_Shift_Operators
21033 Check_Arg_Count
(1);
21034 Check_Arg_Is_Local_Name
(Arg1
);
21036 Arg1
:= Get_Pragma_Arg
(Arg1
);
21038 -- We must have an entity name
21040 if not Is_Entity_Name
(Arg1
) then
21042 ("pragma % must apply to integer first subtype", Arg1
);
21045 -- If no Entity, means there was a prior error so ignore
21047 if Present
(Entity
(Arg1
)) then
21048 Ent
:= Entity
(Arg1
);
21050 -- Apply error checks
21052 if not Is_First_Subtype
(Ent
) then
21054 ("cannot apply pragma %",
21055 "\& is not a first subtype",
21058 elsif not Is_Integer_Type
(Ent
) then
21060 ("cannot apply pragma %",
21061 "\& is not an integer type",
21064 elsif Has_Shift_Operator
(Ent
) then
21066 ("cannot apply pragma %",
21067 "\& already has declared shift operators",
21070 elsif Is_Frozen
(Ent
) then
21072 ("pragma % appears too late",
21073 "\& is already frozen",
21077 -- Now declare the operators. We do this during analysis rather
21078 -- than expansion, since we want the operators available if we
21079 -- are operating in -gnatc or ASIS mode.
21081 Declare_Shift_Operator
(Name_Rotate_Left
);
21082 Declare_Shift_Operator
(Name_Rotate_Right
);
21083 Declare_Shift_Operator
(Name_Shift_Left
);
21084 Declare_Shift_Operator
(Name_Shift_Right
);
21085 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
21087 end Provide_Shift_Operators
;
21093 -- pragma Psect_Object (
21094 -- [Internal =>] LOCAL_NAME,
21095 -- [, [External =>] EXTERNAL_SYMBOL]
21096 -- [, [Size =>] EXTERNAL_SYMBOL]);
21098 when Pragma_Common_Object
21099 | Pragma_Psect_Object
21101 Psect_Object
: declare
21102 Args
: Args_List
(1 .. 3);
21103 Names
: constant Name_List
(1 .. 3) := (
21108 Internal
: Node_Id
renames Args
(1);
21109 External
: Node_Id
renames Args
(2);
21110 Size
: Node_Id
renames Args
(3);
21112 Def_Id
: Entity_Id
;
21114 procedure Check_Arg
(Arg
: Node_Id
);
21115 -- Checks that argument is either a string literal or an
21116 -- identifier, and posts error message if not.
21122 procedure Check_Arg
(Arg
: Node_Id
) is
21124 if not Nkind_In
(Original_Node
(Arg
),
21129 ("inappropriate argument for pragma %", Arg
);
21133 -- Start of processing for Common_Object/Psect_Object
21137 Gather_Associations
(Names
, Args
);
21138 Process_Extended_Import_Export_Internal_Arg
(Internal
);
21140 Def_Id
:= Entity
(Internal
);
21142 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
21144 ("pragma% must designate an object", Internal
);
21147 Check_Arg
(Internal
);
21149 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
21151 ("cannot use pragma% for imported/exported object",
21155 if Is_Concurrent_Type
(Etype
(Internal
)) then
21157 ("cannot specify pragma % for task/protected object",
21161 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
21163 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
21165 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
21168 if Ekind
(Def_Id
) = E_Constant
then
21170 ("cannot specify pragma % for a constant", Internal
);
21173 if Is_Record_Type
(Etype
(Internal
)) then
21179 Ent
:= First_Entity
(Etype
(Internal
));
21180 while Present
(Ent
) loop
21181 Decl
:= Declaration_Node
(Ent
);
21183 if Ekind
(Ent
) = E_Component
21184 and then Nkind
(Decl
) = N_Component_Declaration
21185 and then Present
(Expression
(Decl
))
21186 and then Warn_On_Export_Import
21189 ("?x?object for pragma % has defaults", Internal
);
21199 if Present
(Size
) then
21203 if Present
(External
) then
21204 Check_Arg_Is_External_Name
(External
);
21207 -- If all error tests pass, link pragma on to the rep item chain
21209 Record_Rep_Item
(Def_Id
, N
);
21216 -- pragma Pure [(library_unit_NAME)];
21218 when Pragma_Pure
=> Pure
: declare
21222 Check_Ada_83_Warning
;
21224 -- If the pragma comes from a subprogram instantiation, nothing to
21225 -- check, this can happen at any level of nesting.
21227 if Is_Wrapper_Package
(Current_Scope
) then
21230 Check_Valid_Library_Unit_Pragma
;
21233 if Nkind
(N
) = N_Null_Statement
then
21237 Ent
:= Find_Lib_Unit_Name
;
21239 -- A pragma that applies to a Ghost entity becomes Ghost for the
21240 -- purposes of legality checks and removal of ignored Ghost code.
21242 Mark_Ghost_Pragma
(N
, Ent
);
21244 if not Debug_Flag_U
then
21246 Set_Has_Pragma_Pure
(Ent
);
21248 if Legacy_Elaboration_Checks
then
21249 Set_Suppress_Elaboration_Warnings
(Ent
);
21254 -------------------
21255 -- Pure_Function --
21256 -------------------
21258 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
21260 when Pragma_Pure_Function
=> Pure_Function
: declare
21261 Def_Id
: Entity_Id
;
21264 Effective
: Boolean := False;
21265 Orig_Def
: Entity_Id
;
21266 Same_Decl
: Boolean := False;
21270 Check_Arg_Count
(1);
21271 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21272 Check_Arg_Is_Local_Name
(Arg1
);
21273 E_Id
:= Get_Pragma_Arg
(Arg1
);
21275 if Etype
(E_Id
) = Any_Type
then
21279 -- Loop through homonyms (overloadings) of referenced entity
21281 E
:= Entity
(E_Id
);
21283 -- A pragma that applies to a Ghost entity becomes Ghost for the
21284 -- purposes of legality checks and removal of ignored Ghost code.
21286 Mark_Ghost_Pragma
(N
, E
);
21288 if Present
(E
) then
21290 Def_Id
:= Get_Base_Subprogram
(E
);
21292 if not Ekind_In
(Def_Id
, E_Function
,
21293 E_Generic_Function
,
21297 ("pragma% requires a function name", Arg1
);
21300 -- When we have a generic function we must jump up a level
21301 -- to the declaration of the wrapper package itself.
21303 Orig_Def
:= Def_Id
;
21305 if Is_Generic_Instance
(Def_Id
) then
21306 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
21307 Orig_Def
:= Parent
(Orig_Def
);
21311 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
21313 Set_Is_Pure
(Def_Id
);
21315 if not Has_Pragma_Pure_Function
(Def_Id
) then
21316 Set_Has_Pragma_Pure_Function
(Def_Id
);
21321 exit when From_Aspect_Specification
(N
);
21323 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
21327 and then Warn_On_Redundant_Constructs
21330 ("pragma Pure_Function on& is redundant?r?",
21333 elsif not Same_Decl
then
21335 ("pragma% argument must be in same declarative part",
21341 --------------------
21342 -- Queuing_Policy --
21343 --------------------
21345 -- pragma Queuing_Policy (policy_IDENTIFIER);
21347 when Pragma_Queuing_Policy
=> declare
21351 Check_Ada_83_Warning
;
21352 Check_Arg_Count
(1);
21353 Check_No_Identifiers
;
21354 Check_Arg_Is_Queuing_Policy
(Arg1
);
21355 Check_Valid_Configuration_Pragma
;
21356 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21357 QP
:= Fold_Upper
(Name_Buffer
(1));
21359 if Queuing_Policy
/= ' '
21360 and then Queuing_Policy
/= QP
21362 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
21363 Error_Pragma
("queuing policy incompatible with policy#");
21365 -- Set new policy, but always preserve System_Location since we
21366 -- like the error message with the run time name.
21369 Queuing_Policy
:= QP
;
21371 if Queuing_Policy_Sloc
/= System_Location
then
21372 Queuing_Policy_Sloc
:= Loc
;
21381 -- pragma Rational, for compatibility with foreign compiler
21383 when Pragma_Rational
=>
21384 Set_Rational_Profile
;
21386 ---------------------
21387 -- Refined_Depends --
21388 ---------------------
21390 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21392 -- DEPENDENCY_RELATION ::=
21394 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21396 -- DEPENDENCY_CLAUSE ::=
21397 -- OUTPUT_LIST =>[+] INPUT_LIST
21398 -- | NULL_DEPENDENCY_CLAUSE
21400 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21402 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21404 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21406 -- OUTPUT ::= NAME | FUNCTION_RESULT
21409 -- where FUNCTION_RESULT is a function Result attribute_reference
21411 -- Characteristics:
21413 -- * Analysis - The annotation undergoes initial checks to verify
21414 -- the legal placement and context. Secondary checks fully analyze
21415 -- the dependency clauses/global list in:
21417 -- Analyze_Refined_Depends_In_Decl_Part
21419 -- * Expansion - None.
21421 -- * Template - The annotation utilizes the generic template of the
21422 -- related subprogram body.
21424 -- * Globals - Capture of global references must occur after full
21427 -- * Instance - The annotation is instantiated automatically when
21428 -- the related generic subprogram body is instantiated.
21430 when Pragma_Refined_Depends
=> Refined_Depends
: declare
21431 Body_Id
: Entity_Id
;
21433 Spec_Id
: Entity_Id
;
21436 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21440 -- Chain the pragma on the contract for further processing by
21441 -- Analyze_Refined_Depends_In_Decl_Part.
21443 Add_Contract_Item
(N
, Body_Id
);
21445 -- The legality checks of pragmas Refined_Depends and
21446 -- Refined_Global are affected by the SPARK mode in effect and
21447 -- the volatility of the context. In addition these two pragmas
21448 -- are subject to an inherent order:
21450 -- 1) Refined_Global
21451 -- 2) Refined_Depends
21453 -- Analyze all these pragmas in the order outlined above
21455 Analyze_If_Present
(Pragma_SPARK_Mode
);
21456 Analyze_If_Present
(Pragma_Volatile_Function
);
21457 Analyze_If_Present
(Pragma_Refined_Global
);
21458 Analyze_Refined_Depends_In_Decl_Part
(N
);
21460 end Refined_Depends
;
21462 --------------------
21463 -- Refined_Global --
21464 --------------------
21466 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21468 -- GLOBAL_SPECIFICATION ::=
21471 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21473 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21475 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21476 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21477 -- GLOBAL_ITEM ::= NAME
21479 -- Characteristics:
21481 -- * Analysis - The annotation undergoes initial checks to verify
21482 -- the legal placement and context. Secondary checks fully analyze
21483 -- the dependency clauses/global list in:
21485 -- Analyze_Refined_Global_In_Decl_Part
21487 -- * Expansion - None.
21489 -- * Template - The annotation utilizes the generic template of the
21490 -- related subprogram body.
21492 -- * Globals - Capture of global references must occur after full
21495 -- * Instance - The annotation is instantiated automatically when
21496 -- the related generic subprogram body is instantiated.
21498 when Pragma_Refined_Global
=> Refined_Global
: declare
21499 Body_Id
: Entity_Id
;
21501 Spec_Id
: Entity_Id
;
21504 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21508 -- Chain the pragma on the contract for further processing by
21509 -- Analyze_Refined_Global_In_Decl_Part.
21511 Add_Contract_Item
(N
, Body_Id
);
21513 -- The legality checks of pragmas Refined_Depends and
21514 -- Refined_Global are affected by the SPARK mode in effect and
21515 -- the volatility of the context. In addition these two pragmas
21516 -- are subject to an inherent order:
21518 -- 1) Refined_Global
21519 -- 2) Refined_Depends
21521 -- Analyze all these pragmas in the order outlined above
21523 Analyze_If_Present
(Pragma_SPARK_Mode
);
21524 Analyze_If_Present
(Pragma_Volatile_Function
);
21525 Analyze_Refined_Global_In_Decl_Part
(N
);
21526 Analyze_If_Present
(Pragma_Refined_Depends
);
21528 end Refined_Global
;
21534 -- pragma Refined_Post (boolean_EXPRESSION);
21536 -- Characteristics:
21538 -- * Analysis - The annotation is fully analyzed immediately upon
21539 -- elaboration as it cannot forward reference entities.
21541 -- * Expansion - The annotation is expanded during the expansion of
21542 -- the related subprogram body contract as performed in:
21544 -- Expand_Subprogram_Contract
21546 -- * Template - The annotation utilizes the generic template of the
21547 -- related subprogram body.
21549 -- * Globals - Capture of global references must occur after full
21552 -- * Instance - The annotation is instantiated automatically when
21553 -- the related generic subprogram body is instantiated.
21555 when Pragma_Refined_Post
=> Refined_Post
: declare
21556 Body_Id
: Entity_Id
;
21558 Spec_Id
: Entity_Id
;
21561 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21563 -- Fully analyze the pragma when it appears inside a subprogram
21564 -- body because it cannot benefit from forward references.
21568 -- Chain the pragma on the contract for completeness
21570 Add_Contract_Item
(N
, Body_Id
);
21572 -- The legality checks of pragma Refined_Post are affected by
21573 -- the SPARK mode in effect and the volatility of the context.
21574 -- Analyze all pragmas in a specific order.
21576 Analyze_If_Present
(Pragma_SPARK_Mode
);
21577 Analyze_If_Present
(Pragma_Volatile_Function
);
21578 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
21580 -- Currently it is not possible to inline pre/postconditions on
21581 -- a subprogram subject to pragma Inline_Always.
21583 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
21587 -------------------
21588 -- Refined_State --
21589 -------------------
21591 -- pragma Refined_State (REFINEMENT_LIST);
21593 -- REFINEMENT_LIST ::=
21594 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
21596 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
21598 -- CONSTITUENT_LIST ::=
21601 -- | (CONSTITUENT {, CONSTITUENT})
21603 -- CONSTITUENT ::= object_NAME | state_NAME
21605 -- Characteristics:
21607 -- * Analysis - The annotation undergoes initial checks to verify
21608 -- the legal placement and context. Secondary checks preanalyze the
21609 -- refinement clauses in:
21611 -- Analyze_Refined_State_In_Decl_Part
21613 -- * Expansion - None.
21615 -- * Template - The annotation utilizes the template of the related
21618 -- * Globals - Capture of global references must occur after full
21621 -- * Instance - The annotation is instantiated automatically when
21622 -- the related generic package body is instantiated.
21624 when Pragma_Refined_State
=> Refined_State
: declare
21625 Pack_Decl
: Node_Id
;
21626 Spec_Id
: Entity_Id
;
21630 Check_No_Identifiers
;
21631 Check_Arg_Count
(1);
21633 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
21635 if Nkind
(Pack_Decl
) /= N_Package_Body
then
21640 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
21642 -- A pragma that applies to a Ghost entity becomes Ghost for the
21643 -- purposes of legality checks and removal of ignored Ghost code.
21645 Mark_Ghost_Pragma
(N
, Spec_Id
);
21647 -- Chain the pragma on the contract for further processing by
21648 -- Analyze_Refined_State_In_Decl_Part.
21650 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
21652 -- The legality checks of pragma Refined_State are affected by the
21653 -- SPARK mode in effect. Analyze all pragmas in a specific order.
21655 Analyze_If_Present
(Pragma_SPARK_Mode
);
21657 -- State refinement is allowed only when the corresponding package
21658 -- declaration has non-null pragma Abstract_State. Refinement not
21659 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
21661 if SPARK_Mode
/= Off
21663 (No
(Abstract_States
(Spec_Id
))
21664 or else Has_Null_Abstract_State
(Spec_Id
))
21667 ("useless refinement, package & does not define abstract "
21668 & "states", N
, Spec_Id
);
21673 -----------------------
21674 -- Relative_Deadline --
21675 -----------------------
21677 -- pragma Relative_Deadline (time_span_EXPRESSION);
21679 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
21680 P
: constant Node_Id
:= Parent
(N
);
21685 Check_No_Identifiers
;
21686 Check_Arg_Count
(1);
21688 Arg
:= Get_Pragma_Arg
(Arg1
);
21690 -- The expression must be analyzed in the special manner described
21691 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
21693 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
21697 if Nkind
(P
) = N_Subprogram_Body
then
21698 Check_In_Main_Program
;
21700 -- Only Task and subprogram cases allowed
21702 elsif Nkind
(P
) /= N_Task_Definition
then
21706 -- Check duplicate pragma before we set the corresponding flag
21708 if Has_Relative_Deadline_Pragma
(P
) then
21709 Error_Pragma
("duplicate pragma% not allowed");
21712 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
21713 -- Relative_Deadline pragma node cannot be inserted in the Rep
21714 -- Item chain of Ent since it is rewritten by the expander as a
21715 -- procedure call statement that will break the chain.
21717 Set_Has_Relative_Deadline_Pragma
(P
);
21718 end Relative_Deadline
;
21720 ------------------------
21721 -- Remote_Access_Type --
21722 ------------------------
21724 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
21726 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
21731 Check_Arg_Count
(1);
21732 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21733 Check_Arg_Is_Local_Name
(Arg1
);
21735 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
21737 -- A pragma that applies to a Ghost entity becomes Ghost for the
21738 -- purposes of legality checks and removal of ignored Ghost code.
21740 Mark_Ghost_Pragma
(N
, E
);
21742 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
21743 and then Ekind
(E
) = E_General_Access_Type
21744 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
21745 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
21747 and then Is_Valid_Remote_Object_Type
21748 (Root_Type
(Directly_Designated_Type
(E
)))
21750 Set_Is_Remote_Types
(E
);
21754 ("pragma% applies only to formal access-to-class-wide types",
21757 end Remote_Access_Type
;
21759 ---------------------------
21760 -- Remote_Call_Interface --
21761 ---------------------------
21763 -- pragma Remote_Call_Interface [(library_unit_NAME)];
21765 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
21766 Cunit_Node
: Node_Id
;
21767 Cunit_Ent
: Entity_Id
;
21771 Check_Ada_83_Warning
;
21772 Check_Valid_Library_Unit_Pragma
;
21774 if Nkind
(N
) = N_Null_Statement
then
21778 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21779 K
:= Nkind
(Unit
(Cunit_Node
));
21780 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21782 -- A pragma that applies to a Ghost entity becomes Ghost for the
21783 -- purposes of legality checks and removal of ignored Ghost code.
21785 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21787 if K
= N_Package_Declaration
21788 or else K
= N_Generic_Package_Declaration
21789 or else K
= N_Subprogram_Declaration
21790 or else K
= N_Generic_Subprogram_Declaration
21791 or else (K
= N_Subprogram_Body
21792 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
21797 "pragma% must apply to package or subprogram declaration");
21800 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
21801 end Remote_Call_Interface
;
21807 -- pragma Remote_Types [(library_unit_NAME)];
21809 when Pragma_Remote_Types
=> Remote_Types
: declare
21810 Cunit_Node
: Node_Id
;
21811 Cunit_Ent
: Entity_Id
;
21814 Check_Ada_83_Warning
;
21815 Check_Valid_Library_Unit_Pragma
;
21817 if Nkind
(N
) = N_Null_Statement
then
21821 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21822 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21824 -- A pragma that applies to a Ghost entity becomes Ghost for the
21825 -- purposes of legality checks and removal of ignored Ghost code.
21827 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21829 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21830 N_Generic_Package_Declaration
)
21833 ("pragma% can only apply to a package declaration");
21836 Set_Is_Remote_Types
(Cunit_Ent
);
21843 -- pragma Ravenscar;
21845 when Pragma_Ravenscar
=>
21847 Check_Arg_Count
(0);
21848 Check_Valid_Configuration_Pragma
;
21849 Set_Ravenscar_Profile
(Ravenscar
, N
);
21851 if Warn_On_Obsolescent_Feature
then
21853 ("pragma Ravenscar is an obsolescent feature?j?", N
);
21855 ("|use pragma Profile (Ravenscar) instead?j?", N
);
21858 -------------------------
21859 -- Restricted_Run_Time --
21860 -------------------------
21862 -- pragma Restricted_Run_Time;
21864 when Pragma_Restricted_Run_Time
=>
21866 Check_Arg_Count
(0);
21867 Check_Valid_Configuration_Pragma
;
21868 Set_Profile_Restrictions
21869 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
21871 if Warn_On_Obsolescent_Feature
then
21873 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21876 ("|use pragma Profile (Restricted) instead?j?", N
);
21883 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21886 -- restriction_IDENTIFIER
21887 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21889 when Pragma_Restrictions
=>
21890 Process_Restrictions_Or_Restriction_Warnings
21891 (Warn
=> Treat_Restrictions_As_Warnings
);
21893 --------------------------
21894 -- Restriction_Warnings --
21895 --------------------------
21897 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21900 -- restriction_IDENTIFIER
21901 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21903 when Pragma_Restriction_Warnings
=>
21905 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
21911 -- pragma Reviewable;
21913 when Pragma_Reviewable
=>
21914 Check_Ada_83_Warning
;
21915 Check_Arg_Count
(0);
21917 -- Call dummy debugging function rv. This is done to assist front
21918 -- end debugging. By placing a Reviewable pragma in the source
21919 -- program, a breakpoint on rv catches this place in the source,
21920 -- allowing convenient stepping to the point of interest.
21924 --------------------------
21925 -- Secondary_Stack_Size --
21926 --------------------------
21928 -- pragma Secondary_Stack_Size (EXPRESSION);
21930 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
21931 P
: constant Node_Id
:= Parent
(N
);
21937 Check_No_Identifiers
;
21938 Check_Arg_Count
(1);
21940 if Nkind
(P
) = N_Task_Definition
then
21941 Arg
:= Get_Pragma_Arg
(Arg1
);
21942 Ent
:= Defining_Identifier
(Parent
(P
));
21944 -- The expression must be analyzed in the special manner
21945 -- described in "Handling of Default Expressions" in sem.ads.
21947 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21949 -- The pragma cannot appear if the No_Secondary_Stack
21950 -- restriction is in effect.
21952 Check_Restriction
(No_Secondary_Stack
, Arg
);
21954 -- Anything else is incorrect
21960 -- Check duplicate pragma before we chain the pragma in the Rep
21961 -- Item chain of Ent.
21963 Check_Duplicate_Pragma
(Ent
);
21964 Record_Rep_Item
(Ent
, N
);
21965 end Secondary_Stack_Size
;
21967 --------------------------
21968 -- Short_Circuit_And_Or --
21969 --------------------------
21971 -- pragma Short_Circuit_And_Or;
21973 when Pragma_Short_Circuit_And_Or
=>
21975 Check_Arg_Count
(0);
21976 Check_Valid_Configuration_Pragma
;
21977 Short_Circuit_And_Or
:= True;
21979 -------------------
21980 -- Share_Generic --
21981 -------------------
21983 -- pragma Share_Generic (GNAME {, GNAME});
21985 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21987 when Pragma_Share_Generic
=>
21989 Process_Generic_List
;
21995 -- pragma Shared (LOCAL_NAME);
21997 when Pragma_Shared
=>
21999 Process_Atomic_Independent_Shared_Volatile
;
22001 --------------------
22002 -- Shared_Passive --
22003 --------------------
22005 -- pragma Shared_Passive [(library_unit_NAME)];
22007 -- Set the flag Is_Shared_Passive of program unit name entity
22009 when Pragma_Shared_Passive
=> Shared_Passive
: declare
22010 Cunit_Node
: Node_Id
;
22011 Cunit_Ent
: Entity_Id
;
22014 Check_Ada_83_Warning
;
22015 Check_Valid_Library_Unit_Pragma
;
22017 if Nkind
(N
) = N_Null_Statement
then
22021 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22022 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22024 -- A pragma that applies to a Ghost entity becomes Ghost for the
22025 -- purposes of legality checks and removal of ignored Ghost code.
22027 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22029 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22030 N_Generic_Package_Declaration
)
22033 ("pragma% can only apply to a package declaration");
22036 Set_Is_Shared_Passive
(Cunit_Ent
);
22037 end Shared_Passive
;
22039 -----------------------
22040 -- Short_Descriptors --
22041 -----------------------
22043 -- pragma Short_Descriptors;
22045 -- Recognize and validate, but otherwise ignore
22047 when Pragma_Short_Descriptors
=>
22049 Check_Arg_Count
(0);
22050 Check_Valid_Configuration_Pragma
;
22052 ------------------------------
22053 -- Simple_Storage_Pool_Type --
22054 ------------------------------
22056 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22058 when Pragma_Simple_Storage_Pool_Type
=>
22059 Simple_Storage_Pool_Type
: declare
22065 Check_Arg_Count
(1);
22066 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22068 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22069 Find_Type
(Type_Id
);
22070 Typ
:= Entity
(Type_Id
);
22072 if Typ
= Any_Type
then
22076 -- A pragma that applies to a Ghost entity becomes Ghost for the
22077 -- purposes of legality checks and removal of ignored Ghost code.
22079 Mark_Ghost_Pragma
(N
, Typ
);
22081 -- We require the pragma to apply to a type declared in a package
22082 -- declaration, but not (immediately) within a package body.
22084 if Ekind
(Current_Scope
) /= E_Package
22085 or else In_Package_Body
(Current_Scope
)
22088 ("pragma% can only apply to type declared immediately "
22089 & "within a package declaration");
22092 -- A simple storage pool type must be an immutably limited record
22093 -- or private type. If the pragma is given for a private type,
22094 -- the full type is similarly restricted (which is checked later
22095 -- in Freeze_Entity).
22097 if Is_Record_Type
(Typ
)
22098 and then not Is_Limited_View
(Typ
)
22101 ("pragma% can only apply to explicitly limited record type");
22103 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
22105 ("pragma% can only apply to a private type that is limited");
22107 elsif not Is_Record_Type
(Typ
)
22108 and then not Is_Private_Type
(Typ
)
22111 ("pragma% can only apply to limited record or private type");
22114 Record_Rep_Item
(Typ
, N
);
22115 end Simple_Storage_Pool_Type
;
22117 ----------------------
22118 -- Source_File_Name --
22119 ----------------------
22121 -- There are five forms for this pragma:
22123 -- pragma Source_File_Name (
22124 -- [UNIT_NAME =>] unit_NAME,
22125 -- BODY_FILE_NAME => STRING_LITERAL
22126 -- [, [INDEX =>] INTEGER_LITERAL]);
22128 -- pragma Source_File_Name (
22129 -- [UNIT_NAME =>] unit_NAME,
22130 -- SPEC_FILE_NAME => STRING_LITERAL
22131 -- [, [INDEX =>] INTEGER_LITERAL]);
22133 -- pragma Source_File_Name (
22134 -- BODY_FILE_NAME => STRING_LITERAL
22135 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22136 -- [, CASING => CASING_SPEC]);
22138 -- pragma Source_File_Name (
22139 -- SPEC_FILE_NAME => STRING_LITERAL
22140 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22141 -- [, CASING => CASING_SPEC]);
22143 -- pragma Source_File_Name (
22144 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22145 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22146 -- [, CASING => CASING_SPEC]);
22148 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22150 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22151 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22152 -- only be used when no project file is used, while SFNP can only be
22153 -- used when a project file is used.
22155 -- No processing here. Processing was completed during parsing, since
22156 -- we need to have file names set as early as possible. Units are
22157 -- loaded well before semantic processing starts.
22159 -- The only processing we defer to this point is the check for
22160 -- correct placement.
22162 when Pragma_Source_File_Name
=>
22164 Check_Valid_Configuration_Pragma
;
22166 ------------------------------
22167 -- Source_File_Name_Project --
22168 ------------------------------
22170 -- See Source_File_Name for syntax
22172 -- No processing here. Processing was completed during parsing, since
22173 -- we need to have file names set as early as possible. Units are
22174 -- loaded well before semantic processing starts.
22176 -- The only processing we defer to this point is the check for
22177 -- correct placement.
22179 when Pragma_Source_File_Name_Project
=>
22181 Check_Valid_Configuration_Pragma
;
22183 -- Check that a pragma Source_File_Name_Project is used only in a
22184 -- configuration pragmas file.
22186 -- Pragmas Source_File_Name_Project should only be generated by
22187 -- the Project Manager in configuration pragmas files.
22189 -- This is really an ugly test. It seems to depend on some
22190 -- accidental and undocumented property. At the very least it
22191 -- needs to be documented, but it would be better to have a
22192 -- clean way of testing if we are in a configuration file???
22194 if Present
(Parent
(N
)) then
22196 ("pragma% can only appear in a configuration pragmas file");
22199 ----------------------
22200 -- Source_Reference --
22201 ----------------------
22203 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22205 -- Nothing to do, all processing completed in Par.Prag, since we need
22206 -- the information for possible parser messages that are output.
22208 when Pragma_Source_Reference
=>
22215 -- pragma SPARK_Mode [(On | Off)];
22217 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
22218 Mode_Id
: SPARK_Mode_Type
;
22220 procedure Check_Pragma_Conformance
22221 (Context_Pragma
: Node_Id
;
22222 Entity
: Entity_Id
;
22223 Entity_Pragma
: Node_Id
);
22224 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22225 -- conformance of pragma N depending the following scenarios:
22227 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22228 -- compatible with the pragma Context_Pragma that was inherited
22229 -- from the context:
22230 -- * If the mode of Context_Pragma is ON, then the new mode can
22232 -- * If the mode of Context_Pragma is OFF, then the only allowed
22233 -- new mode is also OFF. Emit error if this is not the case.
22235 -- If Entity is not Empty, verify that pragma N is compatible with
22236 -- pragma Entity_Pragma that belongs to Entity.
22237 -- * If Entity_Pragma is Empty, always issue an error as this
22238 -- corresponds to the case where a previous section of Entity
22239 -- has no SPARK_Mode set.
22240 -- * If the mode of Entity_Pragma is ON, then the new mode can
22242 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22243 -- new mode is also OFF. Emit error if this is not the case.
22245 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
22246 -- Subsidiary to routines Process_xxx. Verify that the related
22247 -- entity E subject to pragma SPARK_Mode is library-level.
22249 procedure Process_Body
(Decl
: Node_Id
);
22250 -- Verify the legality of pragma SPARK_Mode when it appears as the
22251 -- top of the body declarations of entry, package, protected unit,
22252 -- subprogram or task unit body denoted by Decl.
22254 procedure Process_Overloadable
(Decl
: Node_Id
);
22255 -- Verify the legality of pragma SPARK_Mode when it applies to an
22256 -- entry or [generic] subprogram declaration denoted by Decl.
22258 procedure Process_Private_Part
(Decl
: Node_Id
);
22259 -- Verify the legality of pragma SPARK_Mode when it appears at the
22260 -- top of the private declarations of a package spec, protected or
22261 -- task unit declaration denoted by Decl.
22263 procedure Process_Statement_Part
(Decl
: Node_Id
);
22264 -- Verify the legality of pragma SPARK_Mode when it appears at the
22265 -- top of the statement sequence of a package body denoted by node
22268 procedure Process_Visible_Part
(Decl
: Node_Id
);
22269 -- Verify the legality of pragma SPARK_Mode when it appears at the
22270 -- top of the visible declarations of a package spec, protected or
22271 -- task unit declaration denoted by Decl. The routine is also used
22272 -- on protected or task units declared without a definition.
22274 procedure Set_SPARK_Context
;
22275 -- Subsidiary to routines Process_xxx. Set the global variables
22276 -- which represent the mode of the context from pragma N. Ensure
22277 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
22279 ------------------------------
22280 -- Check_Pragma_Conformance --
22281 ------------------------------
22283 procedure Check_Pragma_Conformance
22284 (Context_Pragma
: Node_Id
;
22285 Entity
: Entity_Id
;
22286 Entity_Pragma
: Node_Id
)
22288 Err_Id
: Entity_Id
;
22292 -- The current pragma may appear without an argument. If this
22293 -- is the case, associate all error messages with the pragma
22296 if Present
(Arg1
) then
22302 -- The mode of the current pragma is compared against that of
22303 -- an enclosing context.
22305 if Present
(Context_Pragma
) then
22306 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
22308 -- Issue an error if the new mode is less restrictive than
22309 -- that of the context.
22311 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
22312 and then Get_SPARK_Mode_From_Annotation
(N
) = On
22315 ("cannot change SPARK_Mode from Off to On", Err_N
);
22316 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
22317 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
22322 -- The mode of the current pragma is compared against that of
22323 -- an initial package, protected type, subprogram or task type
22326 if Present
(Entity
) then
22328 -- A simple protected or task type is transformed into an
22329 -- anonymous type whose name cannot be used to issue error
22330 -- messages. Recover the original entity of the type.
22332 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
22335 (Original_Node
(Unit_Declaration_Node
(Entity
)));
22340 -- Both the initial declaration and the completion carry
22341 -- SPARK_Mode pragmas.
22343 if Present
(Entity_Pragma
) then
22344 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
22346 -- Issue an error if the new mode is less restrictive
22347 -- than that of the initial declaration.
22349 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
22350 and then Get_SPARK_Mode_From_Annotation
(N
) = On
22352 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
22353 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
22355 ("\value Off was set for SPARK_Mode on&#",
22360 -- Otherwise the initial declaration lacks a SPARK_Mode
22361 -- pragma in which case the current pragma is illegal as
22362 -- it cannot "complete".
22365 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
22366 Error_Msg_Sloc
:= Sloc
(Err_Id
);
22368 ("\no value was set for SPARK_Mode on&#",
22373 end Check_Pragma_Conformance
;
22375 --------------------------------
22376 -- Check_Library_Level_Entity --
22377 --------------------------------
22379 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
22380 procedure Add_Entity_To_Name_Buffer
;
22381 -- Add the E_Kind of entity E to the name buffer
22383 -------------------------------
22384 -- Add_Entity_To_Name_Buffer --
22385 -------------------------------
22387 procedure Add_Entity_To_Name_Buffer
is
22389 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
22390 Add_Str_To_Name_Buffer
("entry");
22392 elsif Ekind_In
(E
, E_Generic_Package
,
22396 Add_Str_To_Name_Buffer
("package");
22398 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
22399 Add_Str_To_Name_Buffer
("protected type");
22401 elsif Ekind_In
(E
, E_Function
,
22402 E_Generic_Function
,
22403 E_Generic_Procedure
,
22407 Add_Str_To_Name_Buffer
("subprogram");
22410 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
22411 Add_Str_To_Name_Buffer
("task type");
22413 end Add_Entity_To_Name_Buffer
;
22417 Msg_1
: constant String := "incorrect placement of pragma%";
22420 -- Start of processing for Check_Library_Level_Entity
22423 if not Is_Library_Level_Entity
(E
) then
22424 Error_Msg_Name_1
:= Pname
;
22425 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
22428 Add_Str_To_Name_Buffer
("\& is not a library-level ");
22429 Add_Entity_To_Name_Buffer
;
22431 Msg_2
:= Name_Find
;
22432 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
22436 end Check_Library_Level_Entity
;
22442 procedure Process_Body
(Decl
: Node_Id
) is
22443 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22444 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
22447 -- Ignore pragma when applied to the special body created for
22448 -- inlining, recognized by its internal name _Parent.
22450 if Chars
(Body_Id
) = Name_uParent
then
22454 Check_Library_Level_Entity
(Body_Id
);
22456 -- For entry bodies, verify the legality against:
22457 -- * The mode of the context
22458 -- * The mode of the spec (if any)
22460 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
22462 -- A stand-alone subprogram body
22464 if Body_Id
= Spec_Id
then
22465 Check_Pragma_Conformance
22466 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22468 Entity_Pragma
=> Empty
);
22470 -- An entry or subprogram body that completes a previous
22474 Check_Pragma_Conformance
22475 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22477 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22481 Set_SPARK_Pragma
(Body_Id
, N
);
22482 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22484 -- For package bodies, verify the legality against:
22485 -- * The mode of the context
22486 -- * The mode of the private part
22488 -- This case is separated from protected and task bodies
22489 -- because the statement part of the package body inherits
22490 -- the mode of the body declarations.
22492 elsif Nkind
(Decl
) = N_Package_Body
then
22493 Check_Pragma_Conformance
22494 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22496 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22499 Set_SPARK_Pragma
(Body_Id
, N
);
22500 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22501 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22502 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
22504 -- For protected and task bodies, verify the legality against:
22505 -- * The mode of the context
22506 -- * The mode of the private part
22510 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
22512 Check_Pragma_Conformance
22513 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22515 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22518 Set_SPARK_Pragma
(Body_Id
, N
);
22519 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22523 --------------------------
22524 -- Process_Overloadable --
22525 --------------------------
22527 procedure Process_Overloadable
(Decl
: Node_Id
) is
22528 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22529 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
22532 Check_Library_Level_Entity
(Spec_Id
);
22534 -- Verify the legality against:
22535 -- * The mode of the context
22537 Check_Pragma_Conformance
22538 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22540 Entity_Pragma
=> Empty
);
22542 Set_SPARK_Pragma
(Spec_Id
, N
);
22543 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22545 -- When the pragma applies to the anonymous object created for
22546 -- a single task type, decorate the type as well. This scenario
22547 -- arises when the single task type lacks a task definition,
22548 -- therefore there is no issue with respect to a potential
22549 -- pragma SPARK_Mode in the private part.
22551 -- task type Anon_Task_Typ;
22552 -- Obj : Anon_Task_Typ;
22553 -- pragma SPARK_Mode ...;
22555 if Is_Single_Task_Object
(Spec_Id
) then
22556 Set_SPARK_Pragma
(Spec_Typ
, N
);
22557 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
22558 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
22559 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
22561 end Process_Overloadable
;
22563 --------------------------
22564 -- Process_Private_Part --
22565 --------------------------
22567 procedure Process_Private_Part
(Decl
: Node_Id
) is
22568 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22571 Check_Library_Level_Entity
(Spec_Id
);
22573 -- Verify the legality against:
22574 -- * The mode of the visible declarations
22576 Check_Pragma_Conformance
22577 (Context_Pragma
=> Empty
,
22579 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22582 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22583 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
22584 end Process_Private_Part
;
22586 ----------------------------
22587 -- Process_Statement_Part --
22588 ----------------------------
22590 procedure Process_Statement_Part
(Decl
: Node_Id
) is
22591 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22594 Check_Library_Level_Entity
(Body_Id
);
22596 -- Verify the legality against:
22597 -- * The mode of the body declarations
22599 Check_Pragma_Conformance
22600 (Context_Pragma
=> Empty
,
22602 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
22605 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22606 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
22607 end Process_Statement_Part
;
22609 --------------------------
22610 -- Process_Visible_Part --
22611 --------------------------
22613 procedure Process_Visible_Part
(Decl
: Node_Id
) is
22614 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22615 Obj_Id
: Entity_Id
;
22618 Check_Library_Level_Entity
(Spec_Id
);
22620 -- Verify the legality against:
22621 -- * The mode of the context
22623 Check_Pragma_Conformance
22624 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22626 Entity_Pragma
=> Empty
);
22628 -- A task unit declared without a definition does not set the
22629 -- SPARK_Mode of the context because the task does not have any
22630 -- entries that could inherit the mode.
22632 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
22633 N_Task_Type_Declaration
)
22638 Set_SPARK_Pragma
(Spec_Id
, N
);
22639 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22640 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22641 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
22643 -- When the pragma applies to a single protected or task type,
22644 -- decorate the corresponding anonymous object as well.
22646 -- protected Anon_Prot_Typ is
22647 -- pragma SPARK_Mode ...;
22649 -- end Anon_Prot_Typ;
22651 -- Obj : Anon_Prot_Typ;
22653 if Is_Single_Concurrent_Type
(Spec_Id
) then
22654 Obj_Id
:= Anonymous_Object
(Spec_Id
);
22656 Set_SPARK_Pragma
(Obj_Id
, N
);
22657 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
22659 end Process_Visible_Part
;
22661 -----------------------
22662 -- Set_SPARK_Context --
22663 -----------------------
22665 procedure Set_SPARK_Context
is
22667 SPARK_Mode
:= Mode_Id
;
22668 SPARK_Mode_Pragma
:= N
;
22669 end Set_SPARK_Context
;
22677 -- Start of processing for Do_SPARK_Mode
22680 -- When a SPARK_Mode pragma appears inside an instantiation whose
22681 -- enclosing context has SPARK_Mode set to "off", the pragma has
22682 -- no semantic effect.
22684 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
22685 Rewrite
(N
, Make_Null_Statement
(Loc
));
22691 Check_No_Identifiers
;
22692 Check_At_Most_N_Arguments
(1);
22694 -- Check the legality of the mode (no argument = ON)
22696 if Arg_Count
= 1 then
22697 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22698 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
22703 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
22704 Context
:= Parent
(N
);
22706 -- The pragma appears in a configuration file
22708 if No
(Context
) then
22709 Check_Valid_Configuration_Pragma
;
22711 if Present
(SPARK_Mode_Pragma
) then
22714 Prev
=> SPARK_Mode_Pragma
);
22720 -- The pragma acts as a configuration pragma in a compilation unit
22722 -- pragma SPARK_Mode ...;
22723 -- package Pack is ...;
22725 elsif Nkind
(Context
) = N_Compilation_Unit
22726 and then List_Containing
(N
) = Context_Items
(Context
)
22728 Check_Valid_Configuration_Pragma
;
22731 -- Otherwise the placement of the pragma within the tree dictates
22732 -- its associated construct. Inspect the declarative list where
22733 -- the pragma resides to find a potential construct.
22737 while Present
(Stmt
) loop
22739 -- Skip prior pragmas, but check for duplicates. Note that
22740 -- this also takes care of pragmas generated for aspects.
22742 if Nkind
(Stmt
) = N_Pragma
then
22743 if Pragma_Name
(Stmt
) = Pname
then
22750 -- The pragma applies to an expression function that has
22751 -- already been rewritten into a subprogram declaration.
22753 -- function Expr_Func return ... is (...);
22754 -- pragma SPARK_Mode ...;
22756 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
22757 and then Nkind
(Original_Node
(Stmt
)) =
22758 N_Expression_Function
22760 Process_Overloadable
(Stmt
);
22763 -- The pragma applies to the anonymous object created for a
22764 -- single concurrent type.
22766 -- protected type Anon_Prot_Typ ...;
22767 -- Obj : Anon_Prot_Typ;
22768 -- pragma SPARK_Mode ...;
22770 elsif Nkind
(Stmt
) = N_Object_Declaration
22771 and then Is_Single_Concurrent_Object
22772 (Defining_Entity
(Stmt
))
22774 Process_Overloadable
(Stmt
);
22777 -- Skip internally generated code
22779 elsif not Comes_From_Source
(Stmt
) then
22782 -- The pragma applies to an entry or [generic] subprogram
22786 -- pragma SPARK_Mode ...;
22789 -- procedure Proc ...;
22790 -- pragma SPARK_Mode ...;
22792 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
22793 N_Subprogram_Declaration
)
22794 or else (Nkind
(Stmt
) = N_Entry_Declaration
22795 and then Is_Protected_Type
22796 (Scope
(Defining_Entity
(Stmt
))))
22798 Process_Overloadable
(Stmt
);
22801 -- Otherwise the pragma does not apply to a legal construct
22802 -- or it does not appear at the top of a declarative or a
22803 -- statement list. Issue an error and stop the analysis.
22813 -- The pragma applies to a package or a subprogram that acts as
22814 -- a compilation unit.
22816 -- procedure Proc ...;
22817 -- pragma SPARK_Mode ...;
22819 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
22820 Context
:= Unit
(Parent
(Context
));
22823 -- The pragma appears at the top of entry, package, protected
22824 -- unit, subprogram or task unit body declarations.
22826 -- entry Ent when ... is
22827 -- pragma SPARK_Mode ...;
22829 -- package body Pack is
22830 -- pragma SPARK_Mode ...;
22832 -- procedure Proc ... is
22833 -- pragma SPARK_Mode;
22835 -- protected body Prot is
22836 -- pragma SPARK_Mode ...;
22838 if Nkind_In
(Context
, N_Entry_Body
,
22844 Process_Body
(Context
);
22846 -- The pragma appears at the top of the visible or private
22847 -- declaration of a package spec, protected or task unit.
22850 -- pragma SPARK_Mode ...;
22852 -- pragma SPARK_Mode ...;
22854 -- protected [type] Prot is
22855 -- pragma SPARK_Mode ...;
22857 -- pragma SPARK_Mode ...;
22859 elsif Nkind_In
(Context
, N_Package_Specification
,
22860 N_Protected_Definition
,
22863 if List_Containing
(N
) = Visible_Declarations
(Context
) then
22864 Process_Visible_Part
(Parent
(Context
));
22866 Process_Private_Part
(Parent
(Context
));
22869 -- The pragma appears at the top of package body statements
22871 -- package body Pack is
22873 -- pragma SPARK_Mode;
22875 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
22876 and then Nkind
(Parent
(Context
)) = N_Package_Body
22878 Process_Statement_Part
(Parent
(Context
));
22880 -- The pragma appeared as an aspect of a [generic] subprogram
22881 -- declaration that acts as a compilation unit.
22884 -- procedure Proc ...;
22885 -- pragma SPARK_Mode ...;
22887 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
22888 N_Subprogram_Declaration
)
22890 Process_Overloadable
(Context
);
22892 -- The pragma does not apply to a legal construct, issue error
22900 --------------------------------
22901 -- Static_Elaboration_Desired --
22902 --------------------------------
22904 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22906 when Pragma_Static_Elaboration_Desired
=>
22908 Check_At_Most_N_Arguments
(1);
22910 if Is_Compilation_Unit
(Current_Scope
)
22911 and then Ekind
(Current_Scope
) = E_Package
22913 Set_Static_Elaboration_Desired
(Current_Scope
, True);
22915 Error_Pragma
("pragma% must apply to a library-level package");
22922 -- pragma Storage_Size (EXPRESSION);
22924 when Pragma_Storage_Size
=> Storage_Size
: declare
22925 P
: constant Node_Id
:= Parent
(N
);
22929 Check_No_Identifiers
;
22930 Check_Arg_Count
(1);
22932 -- The expression must be analyzed in the special manner described
22933 -- in "Handling of Default Expressions" in sem.ads.
22935 Arg
:= Get_Pragma_Arg
(Arg1
);
22936 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22938 if not Is_OK_Static_Expression
(Arg
) then
22939 Check_Restriction
(Static_Storage_Size
, Arg
);
22942 if Nkind
(P
) /= N_Task_Definition
then
22947 if Has_Storage_Size_Pragma
(P
) then
22948 Error_Pragma
("duplicate pragma% not allowed");
22950 Set_Has_Storage_Size_Pragma
(P
, True);
22953 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22961 -- pragma Storage_Unit (NUMERIC_LITERAL);
22963 -- Only permitted argument is System'Storage_Unit value
22965 when Pragma_Storage_Unit
=>
22966 Check_No_Identifiers
;
22967 Check_Arg_Count
(1);
22968 Check_Arg_Is_Integer_Literal
(Arg1
);
22970 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
22971 UI_From_Int
(Ttypes
.System_Storage_Unit
)
22973 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
22975 ("the only allowed argument for pragma% is ^", Arg1
);
22978 --------------------
22979 -- Stream_Convert --
22980 --------------------
22982 -- pragma Stream_Convert (
22983 -- [Entity =>] type_LOCAL_NAME,
22984 -- [Read =>] function_NAME,
22985 -- [Write =>] function NAME);
22987 when Pragma_Stream_Convert
=> Stream_Convert
: declare
22988 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
22989 -- Check that the given argument is the name of a local function
22990 -- of one argument that is not overloaded earlier in the current
22991 -- local scope. A check is also made that the argument is a
22992 -- function with one parameter.
22994 --------------------------------------
22995 -- Check_OK_Stream_Convert_Function --
22996 --------------------------------------
22998 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
23002 Check_Arg_Is_Local_Name
(Arg
);
23003 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
23005 if Has_Homonym
(Ent
) then
23007 ("argument for pragma% may not be overloaded", Arg
);
23010 if Ekind
(Ent
) /= E_Function
23011 or else No
(First_Formal
(Ent
))
23012 or else Present
(Next_Formal
(First_Formal
(Ent
)))
23015 ("argument for pragma% must be function of one argument",
23018 end Check_OK_Stream_Convert_Function
;
23020 -- Start of processing for Stream_Convert
23024 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
23025 Check_Arg_Count
(3);
23026 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23027 Check_Optional_Identifier
(Arg2
, Name_Read
);
23028 Check_Optional_Identifier
(Arg3
, Name_Write
);
23029 Check_Arg_Is_Local_Name
(Arg1
);
23030 Check_OK_Stream_Convert_Function
(Arg2
);
23031 Check_OK_Stream_Convert_Function
(Arg3
);
23034 Typ
: constant Entity_Id
:=
23035 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
23036 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
23037 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
23040 Check_First_Subtype
(Arg1
);
23042 -- Check for too early or too late. Note that we don't enforce
23043 -- the rule about primitive operations in this case, since, as
23044 -- is the case for explicit stream attributes themselves, these
23045 -- restrictions are not appropriate. Note that the chaining of
23046 -- the pragma by Rep_Item_Too_Late is actually the critical
23047 -- processing done for this pragma.
23049 if Rep_Item_Too_Early
(Typ
, N
)
23051 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
23056 -- Return if previous error
23058 if Etype
(Typ
) = Any_Type
23060 Etype
(Read
) = Any_Type
23062 Etype
(Write
) = Any_Type
23069 if Underlying_Type
(Etype
(Read
)) /= Typ
then
23071 ("incorrect return type for function&", Arg2
);
23074 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
23076 ("incorrect parameter type for function&", Arg3
);
23079 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
23080 Underlying_Type
(Etype
(Write
))
23083 ("result type of & does not match Read parameter type",
23087 end Stream_Convert
;
23093 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23095 -- This is processed by the parser since some of the style checks
23096 -- take place during source scanning and parsing. This means that
23097 -- we don't need to issue error messages here.
23099 when Pragma_Style_Checks
=> Style_Checks
: declare
23100 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23106 Check_No_Identifiers
;
23108 -- Two argument form
23110 if Arg_Count
= 2 then
23111 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23118 E_Id
:= Get_Pragma_Arg
(Arg2
);
23121 if not Is_Entity_Name
(E_Id
) then
23123 ("second argument of pragma% must be entity name",
23127 E
:= Entity
(E_Id
);
23129 if not Ignore_Style_Checks_Pragmas
then
23134 Set_Suppress_Style_Checks
23135 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
23136 exit when No
(Homonym
(E
));
23143 -- One argument form
23146 Check_Arg_Count
(1);
23148 if Nkind
(A
) = N_String_Literal
then
23152 Slen
: constant Natural := Natural (String_Length
(S
));
23153 Options
: String (1 .. Slen
);
23159 C
:= Get_String_Char
(S
, Pos
(J
));
23160 exit when not In_Character_Range
(C
);
23161 Options
(J
) := Get_Character
(C
);
23163 -- If at end of string, set options. As per discussion
23164 -- above, no need to check for errors, since we issued
23165 -- them in the parser.
23168 if not Ignore_Style_Checks_Pragmas
then
23169 Set_Style_Check_Options
(Options
);
23179 elsif Nkind
(A
) = N_Identifier
then
23180 if Chars
(A
) = Name_All_Checks
then
23181 if not Ignore_Style_Checks_Pragmas
then
23183 Set_GNAT_Style_Check_Options
;
23185 Set_Default_Style_Check_Options
;
23189 elsif Chars
(A
) = Name_On
then
23190 if not Ignore_Style_Checks_Pragmas
then
23191 Style_Check
:= True;
23194 elsif Chars
(A
) = Name_Off
then
23195 if not Ignore_Style_Checks_Pragmas
then
23196 Style_Check
:= False;
23207 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23209 when Pragma_Subtitle
=>
23211 Check_Arg_Count
(1);
23212 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
23213 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23220 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23222 when Pragma_Suppress
=>
23223 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
23229 -- pragma Suppress_All;
23231 -- The only check made here is that the pragma has no arguments.
23232 -- There are no placement rules, and the processing required (setting
23233 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23234 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23235 -- then creates and inserts a pragma Suppress (All_Checks).
23237 when Pragma_Suppress_All
=>
23239 Check_Arg_Count
(0);
23241 -------------------------
23242 -- Suppress_Debug_Info --
23243 -------------------------
23245 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23247 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
23248 Nam_Id
: Entity_Id
;
23252 Check_Arg_Count
(1);
23253 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23254 Check_Arg_Is_Local_Name
(Arg1
);
23256 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
23258 -- A pragma that applies to a Ghost entity becomes Ghost for the
23259 -- purposes of legality checks and removal of ignored Ghost code.
23261 Mark_Ghost_Pragma
(N
, Nam_Id
);
23262 Set_Debug_Info_Off
(Nam_Id
);
23263 end Suppress_Debug_Info
;
23265 ----------------------------------
23266 -- Suppress_Exception_Locations --
23267 ----------------------------------
23269 -- pragma Suppress_Exception_Locations;
23271 when Pragma_Suppress_Exception_Locations
=>
23273 Check_Arg_Count
(0);
23274 Check_Valid_Configuration_Pragma
;
23275 Exception_Locations_Suppressed
:= True;
23277 -----------------------------
23278 -- Suppress_Initialization --
23279 -----------------------------
23281 -- pragma Suppress_Initialization ([Entity =>] type_Name);
23283 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
23289 Check_Arg_Count
(1);
23290 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23291 Check_Arg_Is_Local_Name
(Arg1
);
23293 E_Id
:= Get_Pragma_Arg
(Arg1
);
23295 if Etype
(E_Id
) = Any_Type
then
23299 E
:= Entity
(E_Id
);
23301 -- A pragma that applies to a Ghost entity becomes Ghost for the
23302 -- purposes of legality checks and removal of ignored Ghost code.
23304 Mark_Ghost_Pragma
(N
, E
);
23306 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
23308 ("pragma% requires variable, type or subtype", Arg1
);
23311 if Rep_Item_Too_Early
(E
, N
)
23313 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
23318 -- For incomplete/private type, set flag on full view
23320 if Is_Incomplete_Or_Private_Type
(E
) then
23321 if No
(Full_View
(Base_Type
(E
))) then
23323 ("argument of pragma% cannot be an incomplete type", Arg1
);
23325 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
23328 -- For first subtype, set flag on base type
23330 elsif Is_First_Subtype
(E
) then
23331 Set_Suppress_Initialization
(Base_Type
(E
));
23333 -- For other than first subtype, set flag on subtype or variable
23336 Set_Suppress_Initialization
(E
);
23344 -- pragma System_Name (DIRECT_NAME);
23346 -- Syntax check: one argument, which must be the identifier GNAT or
23347 -- the identifier GCC, no other identifiers are acceptable.
23349 when Pragma_System_Name
=>
23351 Check_No_Identifiers
;
23352 Check_Arg_Count
(1);
23353 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
23355 -----------------------------
23356 -- Task_Dispatching_Policy --
23357 -----------------------------
23359 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
23361 when Pragma_Task_Dispatching_Policy
=> declare
23365 Check_Ada_83_Warning
;
23366 Check_Arg_Count
(1);
23367 Check_No_Identifiers
;
23368 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
23369 Check_Valid_Configuration_Pragma
;
23370 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23371 DP
:= Fold_Upper
(Name_Buffer
(1));
23373 if Task_Dispatching_Policy
/= ' '
23374 and then Task_Dispatching_Policy
/= DP
23376 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
23378 ("task dispatching policy incompatible with policy#");
23380 -- Set new policy, but always preserve System_Location since we
23381 -- like the error message with the run time name.
23384 Task_Dispatching_Policy
:= DP
;
23386 if Task_Dispatching_Policy_Sloc
/= System_Location
then
23387 Task_Dispatching_Policy_Sloc
:= Loc
;
23396 -- pragma Task_Info (EXPRESSION);
23398 when Pragma_Task_Info
=> Task_Info
: declare
23399 P
: constant Node_Id
:= Parent
(N
);
23405 if Warn_On_Obsolescent_Feature
then
23407 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
23408 & "instead?j?", N
);
23411 if Nkind
(P
) /= N_Task_Definition
then
23412 Error_Pragma
("pragma% must appear in task definition");
23415 Check_No_Identifiers
;
23416 Check_Arg_Count
(1);
23418 Analyze_And_Resolve
23419 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
23421 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
23425 Ent
:= Defining_Identifier
(Parent
(P
));
23427 -- Check duplicate pragma before we chain the pragma in the Rep
23428 -- Item chain of Ent.
23431 (Ent
, Name_Task_Info
, Check_Parents
=> False)
23433 Error_Pragma
("duplicate pragma% not allowed");
23436 Record_Rep_Item
(Ent
, N
);
23443 -- pragma Task_Name (string_EXPRESSION);
23445 when Pragma_Task_Name
=> Task_Name
: declare
23446 P
: constant Node_Id
:= Parent
(N
);
23451 Check_No_Identifiers
;
23452 Check_Arg_Count
(1);
23454 Arg
:= Get_Pragma_Arg
(Arg1
);
23456 -- The expression is used in the call to Create_Task, and must be
23457 -- expanded there, not in the context of the current spec. It must
23458 -- however be analyzed to capture global references, in case it
23459 -- appears in a generic context.
23461 Preanalyze_And_Resolve
(Arg
, Standard_String
);
23463 if Nkind
(P
) /= N_Task_Definition
then
23467 Ent
:= Defining_Identifier
(Parent
(P
));
23469 -- Check duplicate pragma before we chain the pragma in the Rep
23470 -- Item chain of Ent.
23473 (Ent
, Name_Task_Name
, Check_Parents
=> False)
23475 Error_Pragma
("duplicate pragma% not allowed");
23478 Record_Rep_Item
(Ent
, N
);
23485 -- pragma Task_Storage (
23486 -- [Task_Type =>] LOCAL_NAME,
23487 -- [Top_Guard =>] static_integer_EXPRESSION);
23489 when Pragma_Task_Storage
=> Task_Storage
: declare
23490 Args
: Args_List
(1 .. 2);
23491 Names
: constant Name_List
(1 .. 2) := (
23495 Task_Type
: Node_Id
renames Args
(1);
23496 Top_Guard
: Node_Id
renames Args
(2);
23502 Gather_Associations
(Names
, Args
);
23504 if No
(Task_Type
) then
23506 ("missing task_type argument for pragma%");
23509 Check_Arg_Is_Local_Name
(Task_Type
);
23511 Ent
:= Entity
(Task_Type
);
23513 if not Is_Task_Type
(Ent
) then
23515 ("argument for pragma% must be task type", Task_Type
);
23518 if No
(Top_Guard
) then
23520 ("pragma% takes two arguments", Task_Type
);
23522 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
23525 Check_First_Subtype
(Task_Type
);
23527 if Rep_Item_Too_Late
(Ent
, N
) then
23536 -- pragma Test_Case
23537 -- ([Name =>] Static_String_EXPRESSION
23538 -- ,[Mode =>] MODE_TYPE
23539 -- [, Requires => Boolean_EXPRESSION]
23540 -- [, Ensures => Boolean_EXPRESSION]);
23542 -- MODE_TYPE ::= Nominal | Robustness
23544 -- Characteristics:
23546 -- * Analysis - The annotation undergoes initial checks to verify
23547 -- the legal placement and context. Secondary checks preanalyze the
23550 -- Analyze_Test_Case_In_Decl_Part
23552 -- * Expansion - None.
23554 -- * Template - The annotation utilizes the generic template of the
23555 -- related subprogram when it is:
23557 -- aspect on subprogram declaration
23559 -- The annotation must prepare its own template when it is:
23561 -- pragma on subprogram declaration
23563 -- * Globals - Capture of global references must occur after full
23566 -- * Instance - The annotation is instantiated automatically when
23567 -- the related generic subprogram is instantiated except for the
23568 -- "pragma on subprogram declaration" case. In that scenario the
23569 -- annotation must instantiate itself.
23571 when Pragma_Test_Case
=> Test_Case
: declare
23572 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
23573 -- Ensure that the contract of subprogram Subp_Id does not contain
23574 -- another Test_Case pragma with the same Name as the current one.
23576 -------------------------
23577 -- Check_Distinct_Name --
23578 -------------------------
23580 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
23581 Items
: constant Node_Id
:= Contract
(Subp_Id
);
23582 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
23586 -- Inspect all Test_Case pragma of the related subprogram
23587 -- looking for one with a duplicate "Name" argument.
23589 if Present
(Items
) then
23590 Prag
:= Contract_Test_Cases
(Items
);
23591 while Present
(Prag
) loop
23592 if Pragma_Name
(Prag
) = Name_Test_Case
23594 and then String_Equal
23595 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
23597 Error_Msg_Sloc
:= Sloc
(Prag
);
23598 Error_Pragma
("name for pragma % is already used #");
23601 Prag
:= Next_Pragma
(Prag
);
23604 end Check_Distinct_Name
;
23608 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
23611 Subp_Decl
: Node_Id
;
23612 Subp_Id
: Entity_Id
;
23614 -- Start of processing for Test_Case
23618 Check_At_Least_N_Arguments
(2);
23619 Check_At_Most_N_Arguments
(4);
23621 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
23625 Check_Optional_Identifier
(Arg1
, Name_Name
);
23626 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23630 Check_Optional_Identifier
(Arg2
, Name_Mode
);
23631 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
23633 -- Arguments "Requires" and "Ensures"
23635 if Present
(Arg3
) then
23636 if Present
(Arg4
) then
23637 Check_Identifier
(Arg3
, Name_Requires
);
23638 Check_Identifier
(Arg4
, Name_Ensures
);
23640 Check_Identifier_Is_One_Of
23641 (Arg3
, Name_Requires
, Name_Ensures
);
23645 -- Pragma Test_Case must be associated with a subprogram declared
23646 -- in a library-level package. First determine whether the current
23647 -- compilation unit is a legal context.
23649 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
23650 N_Generic_Package_Declaration
)
23654 -- Otherwise the placement is illegal
23658 ("pragma % must be specified within a package declaration");
23662 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
23664 -- Find the enclosing context
23666 Context
:= Parent
(Subp_Decl
);
23668 if Present
(Context
) then
23669 Context
:= Parent
(Context
);
23672 -- Verify the placement of the pragma
23674 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23676 ("pragma % cannot be applied to abstract subprogram");
23679 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
23680 Error_Pragma
("pragma % cannot be applied to entry");
23683 -- The context is a [generic] subprogram declared at the top level
23684 -- of the [generic] package unit.
23686 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
23687 N_Subprogram_Declaration
)
23688 and then Present
(Context
)
23689 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
23690 N_Package_Declaration
)
23694 -- Otherwise the placement is illegal
23698 ("pragma % must be applied to a library-level subprogram "
23703 Subp_Id
:= Defining_Entity
(Subp_Decl
);
23705 -- A pragma that applies to a Ghost entity becomes Ghost for the
23706 -- purposes of legality checks and removal of ignored Ghost code.
23708 Mark_Ghost_Pragma
(N
, Subp_Id
);
23710 -- Chain the pragma on the contract for further processing by
23711 -- Analyze_Test_Case_In_Decl_Part.
23713 Add_Contract_Item
(N
, Subp_Id
);
23715 -- Preanalyze the original aspect argument "Name" for ASIS or for
23716 -- a generic subprogram to properly capture global references.
23718 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
23719 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
23721 if Present
(Asp_Arg
) then
23723 -- The argument appears with an identifier in association
23726 if Nkind
(Asp_Arg
) = N_Component_Association
then
23727 Asp_Arg
:= Expression
(Asp_Arg
);
23730 Check_Expr_Is_OK_Static_Expression
23731 (Asp_Arg
, Standard_String
);
23735 -- Ensure that the all Test_Case pragmas of the related subprogram
23736 -- have distinct names.
23738 Check_Distinct_Name
(Subp_Id
);
23740 -- Fully analyze the pragma when it appears inside an entry
23741 -- or subprogram body because it cannot benefit from forward
23744 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
23746 N_Subprogram_Body_Stub
)
23748 -- The legality checks of pragma Test_Case are affected by the
23749 -- SPARK mode in effect and the volatility of the context.
23750 -- Analyze all pragmas in a specific order.
23752 Analyze_If_Present
(Pragma_SPARK_Mode
);
23753 Analyze_If_Present
(Pragma_Volatile_Function
);
23754 Analyze_Test_Case_In_Decl_Part
(N
);
23758 --------------------------
23759 -- Thread_Local_Storage --
23760 --------------------------
23762 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
23764 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
23770 Check_Arg_Count
(1);
23771 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23772 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23774 Id
:= Get_Pragma_Arg
(Arg1
);
23777 if not Is_Entity_Name
(Id
)
23778 or else Ekind
(Entity
(Id
)) /= E_Variable
23780 Error_Pragma_Arg
("local variable name required", Arg1
);
23785 -- A pragma that applies to a Ghost entity becomes Ghost for the
23786 -- purposes of legality checks and removal of ignored Ghost code.
23788 Mark_Ghost_Pragma
(N
, E
);
23790 if Rep_Item_Too_Early
(E
, N
)
23792 Rep_Item_Too_Late
(E
, N
)
23797 Set_Has_Pragma_Thread_Local_Storage
(E
);
23798 Set_Has_Gigi_Rep_Item
(E
);
23799 end Thread_Local_Storage
;
23805 -- pragma Time_Slice (static_duration_EXPRESSION);
23807 when Pragma_Time_Slice
=> Time_Slice
: declare
23813 Check_Arg_Count
(1);
23814 Check_No_Identifiers
;
23815 Check_In_Main_Program
;
23816 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
23818 if not Error_Posted
(Arg1
) then
23820 while Present
(Nod
) loop
23821 if Nkind
(Nod
) = N_Pragma
23822 and then Pragma_Name
(Nod
) = Name_Time_Slice
23824 Error_Msg_Name_1
:= Pname
;
23825 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
23832 -- Process only if in main unit
23834 if Get_Source_Unit
(Loc
) = Main_Unit
then
23835 Opt
.Time_Slice_Set
:= True;
23836 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
23838 if Val
<= Ureal_0
then
23839 Opt
.Time_Slice_Value
:= 0;
23841 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
23842 Opt
.Time_Slice_Value
:= 1_000_000_000
;
23845 Opt
.Time_Slice_Value
:=
23846 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
23855 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
23857 -- TITLING_OPTION ::=
23858 -- [Title =>] STRING_LITERAL
23859 -- | [Subtitle =>] STRING_LITERAL
23861 when Pragma_Title
=> Title
: declare
23862 Args
: Args_List
(1 .. 2);
23863 Names
: constant Name_List
(1 .. 2) := (
23869 Gather_Associations
(Names
, Args
);
23872 for J
in 1 .. 2 loop
23873 if Present
(Args
(J
)) then
23874 Check_Arg_Is_OK_Static_Expression
23875 (Args
(J
), Standard_String
);
23880 ----------------------------
23881 -- Type_Invariant[_Class] --
23882 ----------------------------
23884 -- pragma Type_Invariant[_Class]
23885 -- ([Entity =>] type_LOCAL_NAME,
23886 -- [Check =>] EXPRESSION);
23888 when Pragma_Type_Invariant
23889 | Pragma_Type_Invariant_Class
23891 Type_Invariant
: declare
23892 I_Pragma
: Node_Id
;
23895 Check_Arg_Count
(2);
23897 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23898 -- setting Class_Present for the Type_Invariant_Class case.
23900 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
23901 I_Pragma
:= New_Copy
(N
);
23902 Set_Pragma_Identifier
23903 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
23904 Rewrite
(N
, I_Pragma
);
23905 Set_Analyzed
(N
, False);
23907 end Type_Invariant
;
23909 ---------------------
23910 -- Unchecked_Union --
23911 ---------------------
23913 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23915 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
23916 Assoc
: constant Node_Id
:= Arg1
;
23917 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
23927 Check_No_Identifiers
;
23928 Check_Arg_Count
(1);
23929 Check_Arg_Is_Local_Name
(Arg1
);
23931 Find_Type
(Type_Id
);
23933 Typ
:= Entity
(Type_Id
);
23935 -- A pragma that applies to a Ghost entity becomes Ghost for the
23936 -- purposes of legality checks and removal of ignored Ghost code.
23938 Mark_Ghost_Pragma
(N
, Typ
);
23941 or else Rep_Item_Too_Early
(Typ
, N
)
23945 Typ
:= Underlying_Type
(Typ
);
23948 if Rep_Item_Too_Late
(Typ
, N
) then
23952 Check_First_Subtype
(Arg1
);
23954 -- Note remaining cases are references to a type in the current
23955 -- declarative part. If we find an error, we post the error on
23956 -- the relevant type declaration at an appropriate point.
23958 if not Is_Record_Type
(Typ
) then
23959 Error_Msg_N
("unchecked union must be record type", Typ
);
23962 elsif Is_Tagged_Type
(Typ
) then
23963 Error_Msg_N
("unchecked union must not be tagged", Typ
);
23966 elsif not Has_Discriminants
(Typ
) then
23968 ("unchecked union must have one discriminant", Typ
);
23971 -- Note: in previous versions of GNAT we used to check for limited
23972 -- types and give an error, but in fact the standard does allow
23973 -- Unchecked_Union on limited types, so this check was removed.
23975 -- Similarly, GNAT used to require that all discriminants have
23976 -- default values, but this is not mandated by the RM.
23978 -- Proceed with basic error checks completed
23981 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
23982 Clist
:= Component_List
(Tdef
);
23984 -- Check presence of component list and variant part
23986 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
23988 ("unchecked union must have variant part", Tdef
);
23992 -- Check components
23994 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
23995 while Present
(Comp
) loop
23996 Check_Component
(Comp
, Typ
);
23997 Next_Non_Pragma
(Comp
);
24000 -- Check variant part
24002 Vpart
:= Variant_Part
(Clist
);
24004 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
24005 while Present
(Variant
) loop
24006 Check_Variant
(Variant
, Typ
);
24007 Next_Non_Pragma
(Variant
);
24011 Set_Is_Unchecked_Union
(Typ
);
24012 Set_Convention
(Typ
, Convention_C
);
24013 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
24014 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
24015 end Unchecked_Union
;
24017 ----------------------------
24018 -- Unevaluated_Use_Of_Old --
24019 ----------------------------
24021 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24023 when Pragma_Unevaluated_Use_Of_Old
=>
24025 Check_Arg_Count
(1);
24026 Check_No_Identifiers
;
24027 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
24029 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24030 -- a declarative part or a package spec.
24032 if not Is_Configuration_Pragma
then
24033 Check_Is_In_Decl_Part_Or_Package_Spec
;
24036 -- Store proper setting of Uneval_Old
24038 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24039 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
24041 ------------------------
24042 -- Unimplemented_Unit --
24043 ------------------------
24045 -- pragma Unimplemented_Unit;
24047 -- Note: this only gives an error if we are generating code, or if
24048 -- we are in a generic library unit (where the pragma appears in the
24049 -- body, not in the spec).
24051 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
24052 Cunitent
: constant Entity_Id
:=
24053 Cunit_Entity
(Get_Source_Unit
(Loc
));
24054 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
24058 Check_Arg_Count
(0);
24060 if Operating_Mode
= Generate_Code
24061 or else Ent_Kind
= E_Generic_Function
24062 or else Ent_Kind
= E_Generic_Procedure
24063 or else Ent_Kind
= E_Generic_Package
24065 Get_Name_String
(Chars
(Cunitent
));
24066 Set_Casing
(Mixed_Case
);
24067 Write_Str
(Name_Buffer
(1 .. Name_Len
));
24068 Write_Str
(" is not supported in this configuration");
24070 raise Unrecoverable_Error
;
24072 end Unimplemented_Unit
;
24074 ------------------------
24075 -- Universal_Aliasing --
24076 ------------------------
24078 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24080 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
24086 Check_Arg_Count
(1);
24087 Check_Optional_Identifier
(Arg2
, Name_Entity
);
24088 Check_Arg_Is_Local_Name
(Arg1
);
24089 E_Id
:= Get_Pragma_Arg
(Arg1
);
24091 if Etype
(E_Id
) = Any_Type
then
24095 E
:= Entity
(E_Id
);
24097 if not Is_Type
(E
) then
24098 Error_Pragma_Arg
("pragma% requires type", Arg1
);
24101 -- A pragma that applies to a Ghost entity becomes Ghost for the
24102 -- purposes of legality checks and removal of ignored Ghost code.
24104 Mark_Ghost_Pragma
(N
, E
);
24105 Set_Universal_Aliasing
(Base_Type
(E
));
24106 Record_Rep_Item
(E
, N
);
24107 end Universal_Alias
;
24109 --------------------
24110 -- Universal_Data --
24111 --------------------
24113 -- pragma Universal_Data [(library_unit_NAME)];
24115 when Pragma_Universal_Data
=>
24117 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
24123 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24125 when Pragma_Unmodified
=>
24126 Analyze_Unmodified_Or_Unused
;
24132 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24134 -- or when used in a context clause:
24136 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24138 when Pragma_Unreferenced
=>
24139 Analyze_Unreferenced_Or_Unused
;
24141 --------------------------
24142 -- Unreferenced_Objects --
24143 --------------------------
24145 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24147 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
24149 Arg_Expr
: Node_Id
;
24150 Arg_Id
: Entity_Id
;
24152 Ghost_Error_Posted
: Boolean := False;
24153 -- Flag set when an error concerning the illegal mix of Ghost and
24154 -- non-Ghost types is emitted.
24156 Ghost_Id
: Entity_Id
:= Empty
;
24157 -- The entity of the first Ghost type encountered while processing
24158 -- the arguments of the pragma.
24162 Check_At_Least_N_Arguments
(1);
24165 while Present
(Arg
) loop
24166 Check_No_Identifier
(Arg
);
24167 Check_Arg_Is_Local_Name
(Arg
);
24168 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
24170 if Is_Entity_Name
(Arg_Expr
) then
24171 Arg_Id
:= Entity
(Arg_Expr
);
24173 if Is_Type
(Arg_Id
) then
24174 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
24176 -- A pragma that applies to a Ghost entity becomes Ghost
24177 -- for the purposes of legality checks and removal of
24178 -- ignored Ghost code.
24180 Mark_Ghost_Pragma
(N
, Arg_Id
);
24182 -- Capture the entity of the first Ghost type being
24183 -- processed for error detection purposes.
24185 if Is_Ghost_Entity
(Arg_Id
) then
24186 if No
(Ghost_Id
) then
24187 Ghost_Id
:= Arg_Id
;
24190 -- Otherwise the type is non-Ghost. It is illegal to mix
24191 -- references to Ghost and non-Ghost entities
24194 elsif Present
(Ghost_Id
)
24195 and then not Ghost_Error_Posted
24197 Ghost_Error_Posted
:= True;
24199 Error_Msg_Name_1
:= Pname
;
24201 ("pragma % cannot mention ghost and non-ghost types",
24204 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
24205 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
24207 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
24208 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
24212 ("argument for pragma% must be type or subtype", Arg
);
24216 ("argument for pragma% must be type or subtype", Arg
);
24221 end Unreferenced_Objects
;
24223 ------------------------------
24224 -- Unreserve_All_Interrupts --
24225 ------------------------------
24227 -- pragma Unreserve_All_Interrupts;
24229 when Pragma_Unreserve_All_Interrupts
=>
24231 Check_Arg_Count
(0);
24233 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
24234 Unreserve_All_Interrupts
:= True;
24241 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24243 when Pragma_Unsuppress
=>
24245 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
24251 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
24253 when Pragma_Unused
=>
24254 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
24255 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
24257 -------------------
24258 -- Use_VADS_Size --
24259 -------------------
24261 -- pragma Use_VADS_Size;
24263 when Pragma_Use_VADS_Size
=>
24265 Check_Arg_Count
(0);
24266 Check_Valid_Configuration_Pragma
;
24267 Use_VADS_Size
:= True;
24269 ---------------------
24270 -- Validity_Checks --
24271 ---------------------
24273 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
24275 when Pragma_Validity_Checks
=> Validity_Checks
: declare
24276 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
24282 Check_Arg_Count
(1);
24283 Check_No_Identifiers
;
24285 -- Pragma always active unless in CodePeer or GNATprove modes,
24286 -- which use a fixed configuration of validity checks.
24288 if not (CodePeer_Mode
or GNATprove_Mode
) then
24289 if Nkind
(A
) = N_String_Literal
then
24293 Slen
: constant Natural := Natural (String_Length
(S
));
24294 Options
: String (1 .. Slen
);
24298 -- Couldn't we use a for loop here over Options'Range???
24302 C
:= Get_String_Char
(S
, Pos
(J
));
24304 -- This is a weird test, it skips setting validity
24305 -- checks entirely if any element of S is out of
24306 -- range of Character, what is that about ???
24308 exit when not In_Character_Range
(C
);
24309 Options
(J
) := Get_Character
(C
);
24312 Set_Validity_Check_Options
(Options
);
24320 elsif Nkind
(A
) = N_Identifier
then
24321 if Chars
(A
) = Name_All_Checks
then
24322 Set_Validity_Check_Options
("a");
24323 elsif Chars
(A
) = Name_On
then
24324 Validity_Checks_On
:= True;
24325 elsif Chars
(A
) = Name_Off
then
24326 Validity_Checks_On
:= False;
24330 end Validity_Checks
;
24336 -- pragma Volatile (LOCAL_NAME);
24338 when Pragma_Volatile
=>
24339 Process_Atomic_Independent_Shared_Volatile
;
24341 -------------------------
24342 -- Volatile_Components --
24343 -------------------------
24345 -- pragma Volatile_Components (array_LOCAL_NAME);
24347 -- Volatile is handled by the same circuit as Atomic_Components
24349 --------------------------
24350 -- Volatile_Full_Access --
24351 --------------------------
24353 -- pragma Volatile_Full_Access (LOCAL_NAME);
24355 when Pragma_Volatile_Full_Access
=>
24357 Process_Atomic_Independent_Shared_Volatile
;
24359 -----------------------
24360 -- Volatile_Function --
24361 -----------------------
24363 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
24365 when Pragma_Volatile_Function
=> Volatile_Function
: declare
24366 Over_Id
: Entity_Id
;
24367 Spec_Id
: Entity_Id
;
24368 Subp_Decl
: Node_Id
;
24372 Check_No_Identifiers
;
24373 Check_At_Most_N_Arguments
(1);
24376 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
24378 -- Generic subprogram
24380 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
24383 -- Body acts as spec
24385 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
24386 and then No
(Corresponding_Spec
(Subp_Decl
))
24390 -- Body stub acts as spec
24392 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24393 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24399 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
24407 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
24409 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
24414 -- A pragma that applies to a Ghost entity becomes Ghost for the
24415 -- purposes of legality checks and removal of ignored Ghost code.
24417 Mark_Ghost_Pragma
(N
, Spec_Id
);
24419 -- Chain the pragma on the contract for completeness
24421 Add_Contract_Item
(N
, Spec_Id
);
24423 -- The legality checks of pragma Volatile_Function are affected by
24424 -- the SPARK mode in effect. Analyze all pragmas in a specific
24427 Analyze_If_Present
(Pragma_SPARK_Mode
);
24429 -- A volatile function cannot override a non-volatile function
24430 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24431 -- in New_Overloaded_Entity, however at that point the pragma has
24432 -- not been processed yet.
24434 Over_Id
:= Overridden_Operation
(Spec_Id
);
24436 if Present
(Over_Id
)
24437 and then not Is_Volatile_Function
(Over_Id
)
24440 ("incompatible volatile function values in effect", Spec_Id
);
24442 Error_Msg_Sloc
:= Sloc
(Over_Id
);
24444 ("\& declared # with Volatile_Function value False",
24447 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
24449 ("\overridden # with Volatile_Function value True",
24453 -- Analyze the Boolean expression (if any)
24455 if Present
(Arg1
) then
24456 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
24458 end Volatile_Function
;
24460 ----------------------
24461 -- Warning_As_Error --
24462 ----------------------
24464 -- pragma Warning_As_Error (static_string_EXPRESSION);
24466 when Pragma_Warning_As_Error
=>
24468 Check_Arg_Count
(1);
24469 Check_No_Identifiers
;
24470 Check_Valid_Configuration_Pragma
;
24472 if not Is_Static_String_Expression
(Arg1
) then
24474 ("argument of pragma% must be static string expression",
24477 -- OK static string expression
24480 Acquire_Warning_Match_String
(Arg1
);
24481 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
24482 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
24483 new String'(Name_Buffer (1 .. Name_Len));
24490 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24492 -- DETAILS ::= On | Off
24493 -- DETAILS ::= On | Off, local_NAME
24494 -- DETAILS ::= static_string_EXPRESSION
24495 -- DETAILS ::= On | Off, static_string_EXPRESSION
24497 -- TOOL_NAME ::= GNAT | GNATProve
24499 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24501 -- Note: If the first argument matches an allowed tool name, it is
24502 -- always considered to be a tool name, even if there is a string
24503 -- variable of that name.
24505 -- Note if the second argument of DETAILS is a local_NAME then the
24506 -- second form is always understood. If the intention is to use
24507 -- the fourth form, then you can write NAME & "" to force the
24508 -- intepretation as a static_string_EXPRESSION.
24510 when Pragma_Warnings => Warnings : declare
24511 Reason : String_Id;
24515 Check_At_Least_N_Arguments (1);
24517 -- See if last argument is labeled Reason. If so, make sure we
24518 -- have a string literal or a concatenation of string literals,
24519 -- and acquire the REASON string. Then remove the REASON argument
24520 -- by decreasing Num_Args by one; Remaining processing looks only
24521 -- at first Num_Args arguments).
24524 Last_Arg : constant Node_Id :=
24525 Last (Pragma_Argument_Associations (N));
24528 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24529 and then Chars (Last_Arg) = Name_Reason
24532 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24533 Reason := End_String;
24534 Arg_Count := Arg_Count - 1;
24536 -- Not allowed in compiler units (bootstrap issues)
24538 Check_Compiler_Unit ("Reason for pragma Warnings", N);
24540 -- No REASON string, set null string as reason
24543 Reason := Null_String_Id;
24547 -- Now proceed with REASON taken care of and eliminated
24549 Check_No_Identifiers;
24551 -- If debug flag -gnatd.i is set, pragma is ignored
24553 if Debug_Flag_Dot_I then
24557 -- Process various forms of the pragma
24560 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
24561 Shifted_Args : List_Id;
24564 -- See if first argument is a tool name, currently either
24565 -- GNAT or GNATprove. If so, either ignore the pragma if the
24566 -- tool used does not match, or continue as if no tool name
24567 -- was given otherwise, by shifting the arguments.
24569 if Nkind (Argx) = N_Identifier
24570 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
24572 if Chars (Argx) = Name_Gnat then
24573 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
24574 Rewrite (N, Make_Null_Statement (Loc));
24579 elsif Chars (Argx) = Name_Gnatprove then
24580 if not GNATprove_Mode then
24581 Rewrite (N, Make_Null_Statement (Loc));
24587 raise Program_Error;
24590 -- At this point, the pragma Warnings applies to the tool,
24591 -- so continue with shifted arguments.
24593 Arg_Count := Arg_Count - 1;
24595 if Arg_Count = 1 then
24596 Shifted_Args := New_List (New_Copy (Arg2));
24597 elsif Arg_Count = 2 then
24598 Shifted_Args := New_List (New_Copy (Arg2),
24600 elsif Arg_Count = 3 then
24601 Shifted_Args := New_List (New_Copy (Arg2),
24605 raise Program_Error;
24610 Chars => Name_Warnings,
24611 Pragma_Argument_Associations => Shifted_Args));
24616 -- One argument case
24618 if Arg_Count = 1 then
24620 -- On/Off one argument case was processed by parser
24622 if Nkind (Argx) = N_Identifier
24623 and then Nam_In (Chars (Argx), Name_On, Name_Off)
24627 -- One argument case must be ON/OFF or static string expr
24629 elsif not Is_Static_String_Expression (Arg1) then
24631 ("argument of pragma% must be On/Off or static string "
24632 & "expression", Arg1);
24634 -- One argument string expression case
24638 Lit : constant Node_Id := Expr_Value_S (Argx);
24639 Str : constant String_Id := Strval (Lit);
24640 Len : constant Nat := String_Length (Str);
24648 while J <= Len loop
24649 C := Get_String_Char (Str, J);
24650 OK := In_Character_Range (C);
24653 Chr := Get_Character (C);
24655 -- Dash case: only -Wxxx is accepted
24662 C := Get_String_Char (Str, J);
24663 Chr := Get_Character (C);
24664 exit when Chr = 'W
';
24669 elsif J < Len and then Chr = '.' then
24671 C := Get_String_Char (Str, J);
24672 Chr := Get_Character (C);
24674 if not Set_Dot_Warning_Switch (Chr) then
24676 ("invalid warning switch character "
24677 & '.' & Chr, Arg1);
24683 OK := Set_Warning_Switch (Chr);
24688 ("invalid warning switch character " & Chr,
24694 ("invalid wide character in warning switch ",
24703 -- Two or more arguments (must be two)
24706 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24707 Check_Arg_Count (2);
24715 E_Id := Get_Pragma_Arg (Arg2);
24718 -- In the expansion of an inlined body, a reference to
24719 -- the formal may be wrapped in a conversion if the
24720 -- actual is a conversion. Retrieve the real entity name.
24722 if (In_Instance_Body or In_Inlined_Body)
24723 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
24725 E_Id := Expression (E_Id);
24728 -- Entity name case
24730 if Is_Entity_Name (E_Id) then
24731 E := Entity (E_Id);
24738 (E, (Chars (Get_Pragma_Arg (Arg1)) =
24741 -- Suppress elaboration warnings if the entity
24742 -- denotes an elaboration target.
24744 if Is_Elaboration_Target (E) then
24745 Set_Is_Elaboration_Warnings_OK_Id (E, False);
24748 -- For OFF case, make entry in warnings off
24749 -- pragma table for later processing. But we do
24750 -- not do that within an instance, since these
24751 -- warnings are about what is needed in the
24752 -- template, not an instance of it.
24754 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
24755 and then Warn_On_Warnings_Off
24756 and then not In_Instance
24758 Warnings_Off_Pragmas.Append ((N, E, Reason));
24761 if Is_Enumeration_Type (E) then
24765 Lit := First_Literal (E);
24766 while Present (Lit) loop
24767 Set_Warnings_Off (Lit);
24768 Next_Literal (Lit);
24773 exit when No (Homonym (E));
24778 -- Error if not entity or static string expression case
24780 elsif not Is_Static_String_Expression (Arg2) then
24782 ("second argument of pragma% must be entity name "
24783 & "or static string expression", Arg2);
24785 -- Static string expression case
24788 Acquire_Warning_Match_String (Arg2);
24790 -- Note on configuration pragma case: If this is a
24791 -- configuration pragma, then for an OFF pragma, we
24792 -- just set Config True in the call, which is all
24793 -- that needs to be done. For the case of ON, this
24794 -- is normally an error, unless it is canceling the
24795 -- effect of a previous OFF pragma in the same file.
24796 -- In any other case, an error will be signalled (ON
24797 -- with no matching OFF).
24799 -- Note: We set Used if we are inside a generic to
24800 -- disable the test that the non-config case actually
24801 -- cancels a warning. That's because we can't be sure
24802 -- there isn't an instantiation in some other unit
24803 -- where a warning is suppressed.
24805 -- We could do a little better here by checking if the
24806 -- generic unit we are inside is public, but for now
24807 -- we don't bother with that refinement.
24809 if Chars (Argx) = Name_Off then
24810 Set_Specific_Warning_Off
24811 (Loc, Name_Buffer (1 .. Name_Len), Reason,
24812 Config => Is_Configuration_Pragma,
24813 Used => Inside_A_Generic or else In_Instance);
24815 elsif Chars (Argx) = Name_On then
24816 Set_Specific_Warning_On
24817 (Loc, Name_Buffer (1 .. Name_Len), Err);
24821 ("??pragma Warnings On with no matching "
24822 & "Warnings Off", Loc);
24831 -------------------
24832 -- Weak_External --
24833 -------------------
24835 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
24837 when Pragma_Weak_External => Weak_External : declare
24842 Check_Arg_Count (1);
24843 Check_Optional_Identifier (Arg1, Name_Entity);
24844 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24845 Ent := Entity (Get_Pragma_Arg (Arg1));
24847 if Rep_Item_Too_Early (Ent, N) then
24850 Ent := Underlying_Type (Ent);
24853 -- The only processing required is to link this item on to the
24854 -- list of rep items for the given entity. This is accomplished
24855 -- by the call to Rep_Item_Too_Late (when no error is detected
24856 -- and False is returned).
24858 if Rep_Item_Too_Late (Ent, N) then
24861 Set_Has_Gigi_Rep_Item (Ent);
24865 -----------------------------
24866 -- Wide_Character_Encoding --
24867 -----------------------------
24869 -- pragma Wide_Character_Encoding (IDENTIFIER);
24871 when Pragma_Wide_Character_Encoding =>
24874 -- Nothing to do, handled in parser. Note that we do not enforce
24875 -- configuration pragma placement, this pragma can appear at any
24876 -- place in the source, allowing mixed encodings within a single
24881 --------------------
24882 -- Unknown_Pragma --
24883 --------------------
24885 -- Should be impossible, since the case of an unknown pragma is
24886 -- separately processed before the case statement is entered.
24888 when Unknown_Pragma =>
24889 raise Program_Error;
24892 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24893 -- until AI is formally approved.
24895 -- Check_Order_Dependence;
24898 when Pragma_Exit => null;
24899 end Analyze_Pragma;
24901 ---------------------------------------------
24902 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24903 ---------------------------------------------
24905 -- WARNING: This routine manages Ghost regions. Return statements must be
24906 -- replaced by gotos which jump to the end of the routine and restore the
24909 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24911 Freeze_Id : Entity_Id := Empty)
24913 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24914 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24916 Disp_Typ : Entity_Id;
24917 -- The dispatching type of the subprogram subject to the pre- or
24920 function Check_References (Nod : Node_Id) return Traverse_Result;
24921 -- Check that expression Nod does not mention non-primitives of the
24922 -- type, global objects of the type, or other illegalities described
24923 -- and implied by AI12-0113.
24925 ----------------------
24926 -- Check_References --
24927 ----------------------
24929 function Check_References (Nod : Node_Id) return Traverse_Result is
24931 if Nkind (Nod) = N_Function_Call
24932 and then Is_Entity_Name (Name (Nod))
24935 Func : constant Entity_Id := Entity (Name (Nod));
24939 -- An operation of the type must be a primitive
24941 if No (Find_Dispatching_Type (Func)) then
24942 Form := First_Formal (Func);
24943 while Present (Form) loop
24944 if Etype (Form) = Disp_Typ then
24946 ("operation in class-wide condition must be "
24947 & "primitive of &", Nod, Disp_Typ);
24950 Next_Formal (Form);
24953 -- A return object of the type is illegal as well
24955 if Etype (Func) = Disp_Typ
24956 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24959 ("operation in class-wide condition must be primitive "
24960 & "of &", Nod, Disp_Typ);
24963 -- Otherwise we have a call to an overridden primitive, and we
24964 -- will create a common class-wide clone for the body of
24965 -- original operation and its eventual inherited versions. If
24966 -- the original operation dispatches on result it is never
24967 -- inherited and there is no need for a clone. There is not
24968 -- need for a clone either in GNATprove mode, as cases that
24969 -- would require it are rejected (when an inherited primitive
24970 -- calls an overridden operation in a class-wide contract), and
24971 -- the clone would make proof impossible in some cases.
24973 elsif not Is_Abstract_Subprogram (Spec_Id)
24974 and then No (Class_Wide_Clone (Spec_Id))
24975 and then not Has_Controlling_Result (Spec_Id)
24976 and then not GNATprove_Mode
24978 Build_Class_Wide_Clone_Decl (Spec_Id);
24982 elsif Is_Entity_Name (Nod)
24984 (Etype (Nod) = Disp_Typ
24985 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24986 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24989 ("object in class-wide condition must be formal of type &",
24992 elsif Nkind (Nod) = N_Explicit_Dereference
24993 and then (Etype (Nod) = Disp_Typ
24994 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24995 and then (not Is_Entity_Name (Prefix (Nod))
24996 or else not Is_Formal (Entity (Prefix (Nod))))
24999 ("operation in class-wide condition must be primitive of &",
25004 end Check_References;
25006 procedure Check_Class_Wide_Condition is
25007 new Traverse_Proc (Check_References);
25011 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25013 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25014 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25015 -- Save the Ghost-related attributes to restore on exit
25018 Restore_Scope : Boolean := False;
25020 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25023 -- Do not analyze the pragma multiple times
25025 if Is_Analyzed_Pragma (N) then
25029 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25030 -- analysis of the pragma, the Ghost mode at point of declaration and
25031 -- point of analysis may not necessarily be the same. Use the mode in
25032 -- effect at the point of declaration.
25034 Set_Ghost_Mode (N);
25036 -- Ensure that the subprogram and its formals are visible when analyzing
25037 -- the expression of the pragma.
25039 if not In_Open_Scopes (Spec_Id) then
25040 Restore_Scope := True;
25041 Push_Scope (Spec_Id);
25043 if Is_Generic_Subprogram (Spec_Id) then
25044 Install_Generic_Formals (Spec_Id);
25046 Install_Formals (Spec_Id);
25050 Errors := Serious_Errors_Detected;
25051 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25053 -- Emit a clarification message when the expression contains at least
25054 -- one undefined reference, possibly due to contract freezing.
25056 if Errors /= Serious_Errors_Detected
25057 and then Present (Freeze_Id)
25058 and then Has_Undefined_Reference (Expr)
25060 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25063 if Class_Present (N) then
25065 -- Verify that a class-wide condition is legal, i.e. the operation is
25066 -- a primitive of a tagged type. Note that a generic subprogram is
25067 -- not a primitive operation.
25069 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25071 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25072 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25074 if From_Aspect_Specification (N) then
25076 ("aspect % can only be specified for a primitive operation "
25077 & "of a tagged type", Corresponding_Aspect (N));
25079 -- The pragma is a source construct
25083 ("pragma % can only be specified for a primitive operation "
25084 & "of a tagged type", N);
25087 -- Remaining semantic checks require a full tree traversal
25090 Check_Class_Wide_Condition (Expr);
25095 if Restore_Scope then
25099 -- If analysis of the condition indicates that a class-wide clone
25100 -- has been created, build and analyze its declaration.
25102 if Is_Subprogram (Spec_Id)
25103 and then Present (Class_Wide_Clone (Spec_Id))
25105 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25108 -- Currently it is not possible to inline pre/postconditions on a
25109 -- subprogram subject to pragma Inline_Always.
25111 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25112 Set_Is_Analyzed_Pragma (N);
25114 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25115 end Analyze_Pre_Post_Condition_In_Decl_Part;
25117 ------------------------------------------
25118 -- Analyze_Refined_Depends_In_Decl_Part --
25119 ------------------------------------------
25121 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25122 procedure Check_Dependency_Clause
25123 (Spec_Id : Entity_Id;
25124 Dep_Clause : Node_Id;
25125 Dep_States : Elist_Id;
25126 Refinements : List_Id;
25127 Matched_Items : in out Elist_Id);
25128 -- Try to match a single dependency clause Dep_Clause against one or
25129 -- more refinement clauses found in list Refinements. Each successful
25130 -- match eliminates at least one refinement clause from Refinements.
25131 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25132 -- denotes the entities of all abstract states which appear in pragma
25133 -- Depends. Matched_Items contains the entities of all successfully
25134 -- matched items found in pragma Depends.
25136 procedure Check_Output_States
25137 (Spec_Id : Entity_Id;
25138 Spec_Inputs : Elist_Id;
25139 Spec_Outputs : Elist_Id;
25140 Body_Inputs : Elist_Id;
25141 Body_Outputs : Elist_Id);
25142 -- Determine whether pragma Depends contains an output state with a
25143 -- visible refinement and if so, ensure that pragma Refined_Depends
25144 -- mentions all its constituents as outputs. Spec_Id is the entity of
25145 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25146 -- inputs and outputs of the subprogram spec synthesized from pragma
25147 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25148 -- of the subprogram body synthesized from pragma Refined_Depends.
25150 function Collect_States (Clauses : List_Id) return Elist_Id;
25151 -- Given a normalized list of dependencies obtained from calling
25152 -- Normalize_Clauses, return a list containing the entities of all
25153 -- states appearing in dependencies. It helps in checking refinements
25154 -- involving a state and a corresponding constituent which is not a
25155 -- direct constituent of the state.
25157 procedure Normalize_Clauses (Clauses : List_Id);
25158 -- Given a list of dependence or refinement clauses Clauses, normalize
25159 -- each clause by creating multiple dependencies with exactly one input
25162 procedure Remove_Extra_Clauses
25163 (Clauses : List_Id;
25164 Matched_Items : Elist_Id);
25165 -- Given a list of refinement clauses Clauses, remove all clauses whose
25166 -- inputs and/or outputs have been previously matched. See the body for
25167 -- all special cases. Matched_Items contains the entities of all matched
25168 -- items found in pragma Depends.
25170 procedure Report_Extra_Clauses
25171 (Spec_Id : Entity_Id;
25172 Clauses : List_Id);
25173 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25174 -- denotes the entity of the related subprogram.
25176 -----------------------------
25177 -- Check_Dependency_Clause --
25178 -----------------------------
25180 procedure Check_Dependency_Clause
25181 (Spec_Id : Entity_Id;
25182 Dep_Clause : Node_Id;
25183 Dep_States : Elist_Id;
25184 Refinements : List_Id;
25185 Matched_Items : in out Elist_Id)
25187 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25188 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25190 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25191 -- Determine whether dependency item Dep_Item has been matched in a
25192 -- previous clause.
25194 function Is_In_Out_State_Clause return Boolean;
25195 -- Determine whether dependence clause Dep_Clause denotes an abstract
25196 -- state that depends on itself (State => State).
25198 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25199 -- Determine whether item Item denotes an abstract state with visible
25200 -- null refinement.
25202 procedure Match_Items
25203 (Dep_Item : Node_Id;
25204 Ref_Item : Node_Id;
25205 Matched : out Boolean);
25206 -- Try to match dependence item Dep_Item against refinement item
25207 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25208 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25209 -- the following conformance scenarios is in effect:
25210 -- 1) Both items denote null
25211 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25212 -- 3) Both items denote attribute 'Result
25213 -- 4) Both items denote the same object
25214 -- 5) Both items denote the same formal parameter
25215 -- 6) Both items denote the same current instance of a type
25216 -- 7) Both items denote the same discriminant
25217 -- 8) Dep_Item is an abstract state with visible null refinement
25218 -- and Ref_Item denotes null.
25219 -- 9) Dep_Item is an abstract state with visible null refinement
25220 -- and Ref_Item is Empty (special case).
25221 -- 10) Dep_Item is an abstract state with full or partial visible
25222 -- non-null refinement and Ref_Item denotes one of its
25224 -- 11) Dep_Item is an abstract state without a full visible
25225 -- refinement and Ref_Item denotes the same state.
25226 -- When scenario 10 is in effect, the entity of the abstract state
25227 -- denoted by Dep_Item is added to list Refined_States.
25229 procedure Record_Item
(Item_Id
: Entity_Id
);
25230 -- Store the entity of an item denoted by Item_Id in Matched_Items
25232 ------------------------
25233 -- Is_Already_Matched --
25234 ------------------------
25236 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
25237 Item_Id
: Entity_Id
:= Empty
;
25240 -- When the dependency item denotes attribute 'Result, check for
25241 -- the entity of the related subprogram.
25243 if Is_Attribute_Result
(Dep_Item
) then
25244 Item_Id
:= Spec_Id
;
25246 elsif Is_Entity_Name
(Dep_Item
) then
25247 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25251 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
25252 end Is_Already_Matched
;
25254 ----------------------------
25255 -- Is_In_Out_State_Clause --
25256 ----------------------------
25258 function Is_In_Out_State_Clause
return Boolean is
25259 Dep_Input_Id
: Entity_Id
;
25260 Dep_Output_Id
: Entity_Id
;
25263 -- Detect the following clause:
25266 if Is_Entity_Name
(Dep_Input
)
25267 and then Is_Entity_Name
(Dep_Output
)
25269 -- Handle abstract views generated for limited with clauses
25271 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
25272 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
25275 Ekind
(Dep_Input_Id
) = E_Abstract_State
25276 and then Dep_Input_Id
= Dep_Output_Id
;
25280 end Is_In_Out_State_Clause
;
25282 ---------------------------
25283 -- Is_Null_Refined_State --
25284 ---------------------------
25286 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
25287 Item_Id
: Entity_Id
;
25290 if Is_Entity_Name
(Item
) then
25292 -- Handle abstract views generated for limited with clauses
25294 Item_Id
:= Available_View
(Entity_Of
(Item
));
25297 Ekind
(Item_Id
) = E_Abstract_State
25298 and then Has_Null_Visible_Refinement
(Item_Id
);
25302 end Is_Null_Refined_State
;
25308 procedure Match_Items
25309 (Dep_Item
: Node_Id
;
25310 Ref_Item
: Node_Id
;
25311 Matched
: out Boolean)
25313 Dep_Item_Id
: Entity_Id
;
25314 Ref_Item_Id
: Entity_Id
;
25317 -- Assume that the two items do not match
25321 -- A null matches null or Empty (special case)
25323 if Nkind
(Dep_Item
) = N_Null
25324 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
25328 -- Attribute 'Result matches attribute 'Result
25330 elsif Is_Attribute_Result
(Dep_Item
)
25331 and then Is_Attribute_Result
(Ref_Item
)
25333 -- Put the entity of the related function on the list of
25334 -- matched items because attribute 'Result does not carry
25335 -- an entity similar to states and constituents.
25337 Record_Item
(Spec_Id
);
25340 -- Abstract states, current instances of concurrent types,
25341 -- discriminants, formal parameters and objects.
25343 elsif Is_Entity_Name
(Dep_Item
) then
25345 -- Handle abstract views generated for limited with clauses
25347 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25349 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
25351 -- An abstract state with visible null refinement matches
25352 -- null or Empty (special case).
25354 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
25355 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
25357 Record_Item
(Dep_Item_Id
);
25360 -- An abstract state with visible non-null refinement
25361 -- matches one of its constituents, or itself for an
25362 -- abstract state with partial visible refinement.
25364 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
25365 if Is_Entity_Name
(Ref_Item
) then
25366 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
25368 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
25371 and then Present
(Encapsulating_State
(Ref_Item_Id
))
25372 and then Find_Encapsulating_State
25373 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
25375 Record_Item
(Dep_Item_Id
);
25378 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
25379 and then Ref_Item_Id
= Dep_Item_Id
25381 Record_Item
(Dep_Item_Id
);
25386 -- An abstract state without a visible refinement matches
25389 elsif Is_Entity_Name
(Ref_Item
)
25390 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25392 Record_Item
(Dep_Item_Id
);
25396 -- A current instance of a concurrent type, discriminant,
25397 -- formal parameter or an object matches itself.
25399 elsif Is_Entity_Name
(Ref_Item
)
25400 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25402 Record_Item
(Dep_Item_Id
);
25412 procedure Record_Item
(Item_Id
: Entity_Id
) is
25414 if No
(Matched_Items
) then
25415 Matched_Items
:= New_Elmt_List
;
25418 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
25423 Clause_Matched
: Boolean := False;
25424 Dummy
: Boolean := False;
25425 Inputs_Match
: Boolean;
25426 Next_Ref_Clause
: Node_Id
;
25427 Outputs_Match
: Boolean;
25428 Ref_Clause
: Node_Id
;
25429 Ref_Input
: Node_Id
;
25430 Ref_Output
: Node_Id
;
25432 -- Start of processing for Check_Dependency_Clause
25435 -- Do not perform this check in an instance because it was already
25436 -- performed successfully in the generic template.
25438 if Is_Generic_Instance
(Spec_Id
) then
25442 -- Examine all refinement clauses and compare them against the
25443 -- dependence clause.
25445 Ref_Clause
:= First
(Refinements
);
25446 while Present
(Ref_Clause
) loop
25447 Next_Ref_Clause
:= Next
(Ref_Clause
);
25449 -- Obtain the attributes of the current refinement clause
25451 Ref_Input
:= Expression
(Ref_Clause
);
25452 Ref_Output
:= First
(Choices
(Ref_Clause
));
25454 -- The current refinement clause matches the dependence clause
25455 -- when both outputs match and both inputs match. See routine
25456 -- Match_Items for all possible conformance scenarios.
25458 -- Depends Dep_Output => Dep_Input
25462 -- Refined_Depends Ref_Output => Ref_Input
25465 (Dep_Item
=> Dep_Input
,
25466 Ref_Item
=> Ref_Input
,
25467 Matched
=> Inputs_Match
);
25470 (Dep_Item
=> Dep_Output
,
25471 Ref_Item
=> Ref_Output
,
25472 Matched
=> Outputs_Match
);
25474 -- An In_Out state clause may be matched against a refinement with
25475 -- a null input or null output as long as the non-null side of the
25476 -- relation contains a valid constituent of the In_Out_State.
25478 if Is_In_Out_State_Clause
then
25480 -- Depends => (State => State)
25481 -- Refined_Depends => (null => Constit) -- OK
25484 and then not Outputs_Match
25485 and then Nkind
(Ref_Output
) = N_Null
25487 Outputs_Match
:= True;
25490 -- Depends => (State => State)
25491 -- Refined_Depends => (Constit => null) -- OK
25493 if not Inputs_Match
25494 and then Outputs_Match
25495 and then Nkind
(Ref_Input
) = N_Null
25497 Inputs_Match
:= True;
25501 -- The current refinement clause is legally constructed following
25502 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25503 -- the pool of candidates. The seach continues because a single
25504 -- dependence clause may have multiple matching refinements.
25506 if Inputs_Match
and Outputs_Match
then
25507 Clause_Matched
:= True;
25508 Remove
(Ref_Clause
);
25511 Ref_Clause
:= Next_Ref_Clause
;
25514 -- Depending on the order or composition of refinement clauses, an
25515 -- In_Out state clause may not be directly refinable.
25517 -- Refined_State => (State => (Constit_1, Constit_2))
25518 -- Depends => ((Output, State) => (Input, State))
25519 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25521 -- Matching normalized clause (State => State) fails because there is
25522 -- no direct refinement capable of satisfying this relation. Another
25523 -- similar case arises when clauses (Constit_1 => Input) and (Output
25524 -- => Constit_2) are matched first, leaving no candidates for clause
25525 -- (State => State). Both scenarios are legal as long as one of the
25526 -- previous clauses mentioned a valid constituent of State.
25528 if not Clause_Matched
25529 and then Is_In_Out_State_Clause
25530 and then Is_Already_Matched
(Dep_Input
)
25532 Clause_Matched
:= True;
25535 -- A clause where the input is an abstract state with visible null
25536 -- refinement or a 'Result attribute is implicitly matched when the
25537 -- output has already been matched in a previous clause.
25539 -- Refined_State => (State => null)
25540 -- Depends => (Output => State) -- implicitly OK
25541 -- Refined_Depends => (Output => ...)
25542 -- Depends => (...'Result => State) -- implicitly OK
25543 -- Refined_Depends => (...'Result => ...)
25545 if not Clause_Matched
25546 and then Is_Null_Refined_State
(Dep_Input
)
25547 and then Is_Already_Matched
(Dep_Output
)
25549 Clause_Matched
:= True;
25552 -- A clause where the output is an abstract state with visible null
25553 -- refinement is implicitly matched when the input has already been
25554 -- matched in a previous clause.
25556 -- Refined_State => (State => null)
25557 -- Depends => (State => Input) -- implicitly OK
25558 -- Refined_Depends => (... => Input)
25560 if not Clause_Matched
25561 and then Is_Null_Refined_State
(Dep_Output
)
25562 and then Is_Already_Matched
(Dep_Input
)
25564 Clause_Matched
:= True;
25567 -- At this point either all refinement clauses have been examined or
25568 -- pragma Refined_Depends contains a solitary null. Only an abstract
25569 -- state with null refinement can possibly match these cases.
25571 -- Refined_State => (State => null)
25572 -- Depends => (State => null)
25573 -- Refined_Depends => null -- OK
25575 if not Clause_Matched
then
25577 (Dep_Item
=> Dep_Input
,
25579 Matched
=> Inputs_Match
);
25582 (Dep_Item
=> Dep_Output
,
25584 Matched
=> Outputs_Match
);
25586 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
25589 -- If the contents of Refined_Depends are legal, then the current
25590 -- dependence clause should be satisfied either by an explicit match
25591 -- or by one of the special cases.
25593 if not Clause_Matched
then
25595 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
25596 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
25598 end Check_Dependency_Clause
;
25600 -------------------------
25601 -- Check_Output_States --
25602 -------------------------
25604 procedure Check_Output_States
25605 (Spec_Id
: Entity_Id
;
25606 Spec_Inputs
: Elist_Id
;
25607 Spec_Outputs
: Elist_Id
;
25608 Body_Inputs
: Elist_Id
;
25609 Body_Outputs
: Elist_Id
)
25611 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25612 -- Determine whether all constituents of state State_Id with full
25613 -- visible refinement are used as outputs in pragma Refined_Depends.
25614 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
25616 -----------------------------
25617 -- Check_Constituent_Usage --
25618 -----------------------------
25620 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25621 Constits
: constant Elist_Id
:=
25622 Partial_Refinement_Constituents
(State_Id
);
25623 Constit_Elmt
: Elmt_Id
;
25624 Constit_Id
: Entity_Id
;
25625 Only_Partial
: constant Boolean :=
25626 not Has_Visible_Refinement
(State_Id
);
25627 Posted
: Boolean := False;
25630 if Present
(Constits
) then
25631 Constit_Elmt
:= First_Elmt
(Constits
);
25632 while Present
(Constit_Elmt
) loop
25633 Constit_Id
:= Node
(Constit_Elmt
);
25635 -- Issue an error when a constituent of State_Id is used,
25636 -- and State_Id has only partial visible refinement
25637 -- (SPARK RM 7.2.4(3d)).
25639 if Only_Partial
then
25640 if (Present
(Body_Inputs
)
25641 and then Appears_In
(Body_Inputs
, Constit_Id
))
25643 (Present
(Body_Outputs
)
25644 and then Appears_In
(Body_Outputs
, Constit_Id
))
25646 Error_Msg_Name_1
:= Chars
(State_Id
);
25648 ("constituent & of state % cannot be used in "
25649 & "dependence refinement", N
, Constit_Id
);
25650 Error_Msg_Name_1
:= Chars
(State_Id
);
25651 SPARK_Msg_N
("\use state % instead", N
);
25654 -- The constituent acts as an input (SPARK RM 7.2.5(3))
25656 elsif Present
(Body_Inputs
)
25657 and then Appears_In
(Body_Inputs
, Constit_Id
)
25659 Error_Msg_Name_1
:= Chars
(State_Id
);
25661 ("constituent & of state % must act as output in "
25662 & "dependence refinement", N
, Constit_Id
);
25664 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25666 elsif No
(Body_Outputs
)
25667 or else not Appears_In
(Body_Outputs
, Constit_Id
)
25672 ("output state & must be replaced by all its "
25673 & "constituents in dependence refinement",
25678 ("\constituent & is missing in output list",
25682 Next_Elmt
(Constit_Elmt
);
25685 end Check_Constituent_Usage
;
25690 Item_Elmt
: Elmt_Id
;
25691 Item_Id
: Entity_Id
;
25693 -- Start of processing for Check_Output_States
25696 -- Do not perform this check in an instance because it was already
25697 -- performed successfully in the generic template.
25699 if Is_Generic_Instance
(Spec_Id
) then
25702 -- Inspect the outputs of pragma Depends looking for a state with a
25703 -- visible refinement.
25705 elsif Present
(Spec_Outputs
) then
25706 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
25707 while Present
(Item_Elmt
) loop
25708 Item
:= Node
(Item_Elmt
);
25710 -- Deal with the mixed nature of the input and output lists
25712 if Nkind
(Item
) = N_Defining_Identifier
then
25715 Item_Id
:= Available_View
(Entity_Of
(Item
));
25718 if Ekind
(Item_Id
) = E_Abstract_State
then
25720 -- The state acts as an input-output, skip it
25722 if Present
(Spec_Inputs
)
25723 and then Appears_In
(Spec_Inputs
, Item_Id
)
25727 -- Ensure that all of the constituents are utilized as
25728 -- outputs in pragma Refined_Depends.
25730 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25731 Check_Constituent_Usage
(Item_Id
);
25735 Next_Elmt
(Item_Elmt
);
25738 end Check_Output_States
;
25740 --------------------
25741 -- Collect_States --
25742 --------------------
25744 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
25745 procedure Collect_State
25747 States
: in out Elist_Id
);
25748 -- Add the entity of Item to list States when it denotes to a state
25750 -------------------
25751 -- Collect_State --
25752 -------------------
25754 procedure Collect_State
25756 States
: in out Elist_Id
)
25761 if Is_Entity_Name
(Item
) then
25762 Id
:= Entity_Of
(Item
);
25764 if Ekind
(Id
) = E_Abstract_State
then
25765 if No
(States
) then
25766 States
:= New_Elmt_List
;
25769 Append_Unique_Elmt
(Id
, States
);
25779 States
: Elist_Id
:= No_Elist
;
25781 -- Start of processing for Collect_States
25784 Clause
:= First
(Clauses
);
25785 while Present
(Clause
) loop
25786 Input
:= Expression
(Clause
);
25787 Output
:= First
(Choices
(Clause
));
25789 Collect_State
(Input
, States
);
25790 Collect_State
(Output
, States
);
25796 end Collect_States
;
25798 -----------------------
25799 -- Normalize_Clauses --
25800 -----------------------
25802 procedure Normalize_Clauses
(Clauses
: List_Id
) is
25803 procedure Normalize_Inputs
(Clause
: Node_Id
);
25804 -- Normalize clause Clause by creating multiple clauses for each
25805 -- input item of Clause. It is assumed that Clause has exactly one
25806 -- output. The transformation is as follows:
25808 -- Output => (Input_1, Input_2) -- original
25810 -- Output => Input_1 -- normalizations
25811 -- Output => Input_2
25813 procedure Normalize_Outputs
(Clause
: Node_Id
);
25814 -- Normalize clause Clause by creating multiple clause for each
25815 -- output item of Clause. The transformation is as follows:
25817 -- (Output_1, Output_2) => Input -- original
25819 -- Output_1 => Input -- normalization
25820 -- Output_2 => Input
25822 ----------------------
25823 -- Normalize_Inputs --
25824 ----------------------
25826 procedure Normalize_Inputs
(Clause
: Node_Id
) is
25827 Inputs
: constant Node_Id
:= Expression
(Clause
);
25828 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25829 Output
: constant List_Id
:= Choices
(Clause
);
25830 Last_Input
: Node_Id
;
25832 New_Clause
: Node_Id
;
25833 Next_Input
: Node_Id
;
25836 -- Normalization is performed only when the original clause has
25837 -- more than one input. Multiple inputs appear as an aggregate.
25839 if Nkind
(Inputs
) = N_Aggregate
then
25840 Last_Input
:= Last
(Expressions
(Inputs
));
25842 -- Create a new clause for each input
25844 Input
:= First
(Expressions
(Inputs
));
25845 while Present
(Input
) loop
25846 Next_Input
:= Next
(Input
);
25848 -- Unhook the current input from the original input list
25849 -- because it will be relocated to a new clause.
25853 -- Special processing for the last input. At this point the
25854 -- original aggregate has been stripped down to one element.
25855 -- Replace the aggregate by the element itself.
25857 if Input
= Last_Input
then
25858 Rewrite
(Inputs
, Input
);
25860 -- Generate a clause of the form:
25865 Make_Component_Association
(Loc
,
25866 Choices
=> New_Copy_List_Tree
(Output
),
25867 Expression
=> Input
);
25869 -- The new clause contains replicated content that has
25870 -- already been analyzed, mark the clause as analyzed.
25872 Set_Analyzed
(New_Clause
);
25873 Insert_After
(Clause
, New_Clause
);
25876 Input
:= Next_Input
;
25879 end Normalize_Inputs
;
25881 -----------------------
25882 -- Normalize_Outputs --
25883 -----------------------
25885 procedure Normalize_Outputs
(Clause
: Node_Id
) is
25886 Inputs
: constant Node_Id
:= Expression
(Clause
);
25887 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25888 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
25889 Last_Output
: Node_Id
;
25890 New_Clause
: Node_Id
;
25891 Next_Output
: Node_Id
;
25895 -- Multiple outputs appear as an aggregate. Nothing to do when
25896 -- the clause has exactly one output.
25898 if Nkind
(Outputs
) = N_Aggregate
then
25899 Last_Output
:= Last
(Expressions
(Outputs
));
25901 -- Create a clause for each output. Note that each time a new
25902 -- clause is created, the original output list slowly shrinks
25903 -- until there is one item left.
25905 Output
:= First
(Expressions
(Outputs
));
25906 while Present
(Output
) loop
25907 Next_Output
:= Next
(Output
);
25909 -- Unhook the output from the original output list as it
25910 -- will be relocated to a new clause.
25914 -- Special processing for the last output. At this point
25915 -- the original aggregate has been stripped down to one
25916 -- element. Replace the aggregate by the element itself.
25918 if Output
= Last_Output
then
25919 Rewrite
(Outputs
, Output
);
25922 -- Generate a clause of the form:
25923 -- (Output => Inputs)
25926 Make_Component_Association
(Loc
,
25927 Choices
=> New_List
(Output
),
25928 Expression
=> New_Copy_Tree
(Inputs
));
25930 -- The new clause contains replicated content that has
25931 -- already been analyzed. There is not need to reanalyze
25934 Set_Analyzed
(New_Clause
);
25935 Insert_After
(Clause
, New_Clause
);
25938 Output
:= Next_Output
;
25941 end Normalize_Outputs
;
25947 -- Start of processing for Normalize_Clauses
25950 Clause
:= First
(Clauses
);
25951 while Present
(Clause
) loop
25952 Normalize_Outputs
(Clause
);
25956 Clause
:= First
(Clauses
);
25957 while Present
(Clause
) loop
25958 Normalize_Inputs
(Clause
);
25961 end Normalize_Clauses
;
25963 --------------------------
25964 -- Remove_Extra_Clauses --
25965 --------------------------
25967 procedure Remove_Extra_Clauses
25968 (Clauses
: List_Id
;
25969 Matched_Items
: Elist_Id
)
25973 Input_Id
: Entity_Id
;
25974 Next_Clause
: Node_Id
;
25976 State_Id
: Entity_Id
;
25979 Clause
:= First
(Clauses
);
25980 while Present
(Clause
) loop
25981 Next_Clause
:= Next
(Clause
);
25983 Input
:= Expression
(Clause
);
25984 Output
:= First
(Choices
(Clause
));
25986 -- Recognize a clause of the form
25990 -- where Input is a constituent of a state which was already
25991 -- successfully matched. This clause must be removed because it
25992 -- simply indicates that some of the constituents of the state
25995 -- Refined_State => (State => (Constit_1, Constit_2))
25996 -- Depends => (Output => State)
25997 -- Refined_Depends => ((Output => Constit_1), -- State matched
25998 -- (null => Constit_2)) -- OK
26000 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
26002 -- Handle abstract views generated for limited with clauses
26004 Input_Id
:= Available_View
(Entity_Of
(Input
));
26006 -- The input must be a constituent of a state
26008 if Ekind_In
(Input_Id
, E_Abstract_State
,
26011 and then Present
(Encapsulating_State
(Input_Id
))
26013 State_Id
:= Encapsulating_State
(Input_Id
);
26015 -- The state must have a non-null visible refinement and be
26016 -- matched in a previous clause.
26018 if Has_Non_Null_Visible_Refinement
(State_Id
)
26019 and then Contains
(Matched_Items
, State_Id
)
26025 -- Recognize a clause of the form
26029 -- where Output is an arbitrary item. This clause must be removed
26030 -- because a null input legitimately matches anything.
26032 elsif Nkind
(Input
) = N_Null
then
26036 Clause
:= Next_Clause
;
26038 end Remove_Extra_Clauses
;
26040 --------------------------
26041 -- Report_Extra_Clauses --
26042 --------------------------
26044 procedure Report_Extra_Clauses
26045 (Spec_Id
: Entity_Id
;
26051 -- Do not perform this check in an instance because it was already
26052 -- performed successfully in the generic template.
26054 if Is_Generic_Instance
(Spec_Id
) then
26057 elsif Present
(Clauses
) then
26058 Clause
:= First
(Clauses
);
26059 while Present
(Clause
) loop
26061 ("unmatched or extra clause in dependence refinement",
26067 end Report_Extra_Clauses
;
26071 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26072 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26073 Errors
: constant Nat
:= Serious_Errors_Detected
;
26080 Body_Inputs
: Elist_Id
:= No_Elist
;
26081 Body_Outputs
: Elist_Id
:= No_Elist
;
26082 -- The inputs and outputs of the subprogram body synthesized from pragma
26083 -- Refined_Depends.
26085 Dependencies
: List_Id
:= No_List
;
26087 -- The corresponding Depends pragma along with its clauses
26089 Matched_Items
: Elist_Id
:= No_Elist
;
26090 -- A list containing the entities of all successfully matched items
26091 -- found in pragma Depends.
26093 Refinements
: List_Id
:= No_List
;
26094 -- The clauses of pragma Refined_Depends
26096 Spec_Id
: Entity_Id
;
26097 -- The entity of the subprogram subject to pragma Refined_Depends
26099 Spec_Inputs
: Elist_Id
:= No_Elist
;
26100 Spec_Outputs
: Elist_Id
:= No_Elist
;
26101 -- The inputs and outputs of the subprogram spec synthesized from pragma
26104 States
: Elist_Id
:= No_Elist
;
26105 -- A list containing the entities of all states whose constituents
26106 -- appear in pragma Depends.
26108 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26111 -- Do not analyze the pragma multiple times
26113 if Is_Analyzed_Pragma
(N
) then
26117 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26119 -- Use the anonymous object as the proper spec when Refined_Depends
26120 -- applies to the body of a single task type. The object carries the
26121 -- proper Chars as well as all non-refined versions of pragmas.
26123 if Is_Single_Concurrent_Type
(Spec_Id
) then
26124 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26127 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26129 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26130 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26132 if No
(Depends
) then
26134 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26135 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
26139 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26141 -- A null dependency relation renders the refinement useless because it
26142 -- cannot possibly mention abstract states with visible refinement. Note
26143 -- that the inverse is not true as states may be refined to null
26144 -- (SPARK RM 7.2.5(2)).
26146 if Nkind
(Deps
) = N_Null
then
26148 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26149 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
26153 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26154 -- This ensures that the categorization of all refined dependency items
26155 -- is consistent with their role.
26157 Analyze_Depends_In_Decl_Part
(N
);
26159 -- Do not match dependencies against refinements if Refined_Depends is
26160 -- illegal to avoid emitting misleading error.
26162 if Serious_Errors_Detected
= Errors
then
26164 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26165 -- the inputs and outputs of the subprogram spec and body to verify
26166 -- the use of states with visible refinement and their constituents.
26168 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
26169 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
26171 Collect_Subprogram_Inputs_Outputs
26172 (Subp_Id
=> Spec_Id
,
26173 Synthesize
=> True,
26174 Subp_Inputs
=> Spec_Inputs
,
26175 Subp_Outputs
=> Spec_Outputs
,
26176 Global_Seen
=> Dummy
);
26178 Collect_Subprogram_Inputs_Outputs
26179 (Subp_Id
=> Body_Id
,
26180 Synthesize
=> True,
26181 Subp_Inputs
=> Body_Inputs
,
26182 Subp_Outputs
=> Body_Outputs
,
26183 Global_Seen
=> Dummy
);
26185 -- For an output state with a visible refinement, ensure that all
26186 -- constituents appear as outputs in the dependency refinement.
26188 Check_Output_States
26189 (Spec_Id
=> Spec_Id
,
26190 Spec_Inputs
=> Spec_Inputs
,
26191 Spec_Outputs
=> Spec_Outputs
,
26192 Body_Inputs
=> Body_Inputs
,
26193 Body_Outputs
=> Body_Outputs
);
26196 -- Matching is disabled in ASIS because clauses are not normalized as
26197 -- this is a tree altering activity similar to expansion.
26203 -- Multiple dependency clauses appear as component associations of an
26204 -- aggregate. Note that the clauses are copied because the algorithm
26205 -- modifies them and this should not be visible in Depends.
26207 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
26208 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
26209 Normalize_Clauses
(Dependencies
);
26211 -- Gather all states which appear in Depends
26213 States
:= Collect_States
(Dependencies
);
26215 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
26217 if Nkind
(Refs
) = N_Null
then
26218 Refinements
:= No_List
;
26220 -- Multiple dependency clauses appear as component associations of an
26221 -- aggregate. Note that the clauses are copied because the algorithm
26222 -- modifies them and this should not be visible in Refined_Depends.
26224 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
26225 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
26226 Normalize_Clauses
(Refinements
);
26229 -- At this point the clauses of pragmas Depends and Refined_Depends
26230 -- have been normalized into simple dependencies between one output
26231 -- and one input. Examine all clauses of pragma Depends looking for
26232 -- matching clauses in pragma Refined_Depends.
26234 Clause
:= First
(Dependencies
);
26235 while Present
(Clause
) loop
26236 Check_Dependency_Clause
26237 (Spec_Id
=> Spec_Id
,
26238 Dep_Clause
=> Clause
,
26239 Dep_States
=> States
,
26240 Refinements
=> Refinements
,
26241 Matched_Items
=> Matched_Items
);
26246 -- Pragma Refined_Depends may contain multiple clarification clauses
26247 -- which indicate that certain constituents do not influence the data
26248 -- flow in any way. Such clauses must be removed as long as the state
26249 -- has been matched, otherwise they will be incorrectly flagged as
26252 -- Refined_State => (State => (Constit_1, Constit_2))
26253 -- Depends => (Output => State)
26254 -- Refined_Depends => ((Output => Constit_1), -- State matched
26255 -- (null => Constit_2)) -- must be removed
26257 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
26259 if Serious_Errors_Detected
= Errors
then
26260 Report_Extra_Clauses
(Spec_Id
, Refinements
);
26265 Set_Is_Analyzed_Pragma
(N
);
26266 end Analyze_Refined_Depends_In_Decl_Part
;
26268 -----------------------------------------
26269 -- Analyze_Refined_Global_In_Decl_Part --
26270 -----------------------------------------
26272 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
26274 -- The corresponding Global pragma
26276 Has_In_State
: Boolean := False;
26277 Has_In_Out_State
: Boolean := False;
26278 Has_Out_State
: Boolean := False;
26279 Has_Proof_In_State
: Boolean := False;
26280 -- These flags are set when the corresponding Global pragma has a state
26281 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
26284 Has_Null_State
: Boolean := False;
26285 -- This flag is set when the corresponding Global pragma has at least
26286 -- one state with a null refinement.
26288 In_Constits
: Elist_Id
:= No_Elist
;
26289 In_Out_Constits
: Elist_Id
:= No_Elist
;
26290 Out_Constits
: Elist_Id
:= No_Elist
;
26291 Proof_In_Constits
: Elist_Id
:= No_Elist
;
26292 -- These lists contain the entities of all Input, In_Out, Output and
26293 -- Proof_In constituents that appear in Refined_Global and participate
26294 -- in state refinement.
26296 In_Items
: Elist_Id
:= No_Elist
;
26297 In_Out_Items
: Elist_Id
:= No_Elist
;
26298 Out_Items
: Elist_Id
:= No_Elist
;
26299 Proof_In_Items
: Elist_Id
:= No_Elist
;
26300 -- These lists contain the entities of all Input, In_Out, Output and
26301 -- Proof_In items defined in the corresponding Global pragma.
26303 Repeat_Items
: Elist_Id
:= No_Elist
;
26304 -- A list of all global items without full visible refinement found
26305 -- in pragma Global. These states should be repeated in the global
26306 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
26307 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
26309 Spec_Id
: Entity_Id
;
26310 -- The entity of the subprogram subject to pragma Refined_Global
26312 States
: Elist_Id
:= No_Elist
;
26313 -- A list of all states with full or partial visible refinement found in
26316 procedure Check_In_Out_States
;
26317 -- Determine whether the corresponding Global pragma mentions In_Out
26318 -- states with visible refinement and if so, ensure that one of the
26319 -- following completions apply to the constituents of the state:
26320 -- 1) there is at least one constituent of mode In_Out
26321 -- 2) there is at least one Input and one Output constituent
26322 -- 3) not all constituents are present and one of them is of mode
26324 -- This routine may remove elements from In_Constits, In_Out_Constits,
26325 -- Out_Constits and Proof_In_Constits.
26327 procedure Check_Input_States
;
26328 -- Determine whether the corresponding Global pragma mentions Input
26329 -- states with visible refinement and if so, ensure that at least one of
26330 -- its constituents appears as an Input item in Refined_Global.
26331 -- This routine may remove elements from In_Constits, In_Out_Constits,
26332 -- Out_Constits and Proof_In_Constits.
26334 procedure Check_Output_States
;
26335 -- Determine whether the corresponding Global pragma mentions Output
26336 -- states with visible refinement and if so, ensure that all of its
26337 -- constituents appear as Output items in Refined_Global.
26338 -- This routine may remove elements from In_Constits, In_Out_Constits,
26339 -- Out_Constits and Proof_In_Constits.
26341 procedure Check_Proof_In_States
;
26342 -- Determine whether the corresponding Global pragma mentions Proof_In
26343 -- states with visible refinement and if so, ensure that at least one of
26344 -- its constituents appears as a Proof_In item in Refined_Global.
26345 -- This routine may remove elements from In_Constits, In_Out_Constits,
26346 -- Out_Constits and Proof_In_Constits.
26348 procedure Check_Refined_Global_List
26350 Global_Mode
: Name_Id
:= Name_Input
);
26351 -- Verify the legality of a single global list declaration. Global_Mode
26352 -- denotes the current mode in effect.
26354 procedure Collect_Global_Items
26356 Mode
: Name_Id
:= Name_Input
);
26357 -- Gather all Input, In_Out, Output and Proof_In items from node List
26358 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
26359 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
26360 -- and Has_Proof_In_State are set when there is at least one abstract
26361 -- state with full or partial visible refinement available in the
26362 -- corresponding mode. Flag Has_Null_State is set when at least state
26363 -- has a null refinement. Mode denotes the current global mode in
26366 function Present_Then_Remove
26368 Item
: Entity_Id
) return Boolean;
26369 -- Search List for a particular entity Item. If Item has been found,
26370 -- remove it from List. This routine is used to strip lists In_Constits,
26371 -- In_Out_Constits and Out_Constits of valid constituents.
26373 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
26374 -- Same as function Present_Then_Remove, but do not report the presence
26375 -- of Item in List.
26377 procedure Report_Extra_Constituents
;
26378 -- Emit an error for each constituent found in lists In_Constits,
26379 -- In_Out_Constits and Out_Constits.
26381 procedure Report_Missing_Items
;
26382 -- Emit an error for each global item not repeated found in list
26385 -------------------------
26386 -- Check_In_Out_States --
26387 -------------------------
26389 procedure Check_In_Out_States
is
26390 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26391 -- Determine whether one of the following coverage scenarios is in
26393 -- 1) there is at least one constituent of mode In_Out or Output
26394 -- 2) there is at least one pair of constituents with modes Input
26395 -- and Output, or Proof_In and Output.
26396 -- 3) there is at least one constituent of mode Output and not all
26397 -- constituents are present.
26398 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
26400 -----------------------------
26401 -- Check_Constituent_Usage --
26402 -----------------------------
26404 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26405 Constits
: constant Elist_Id
:=
26406 Partial_Refinement_Constituents
(State_Id
);
26407 Constit_Elmt
: Elmt_Id
;
26408 Constit_Id
: Entity_Id
;
26409 Has_Missing
: Boolean := False;
26410 In_Out_Seen
: Boolean := False;
26411 Input_Seen
: Boolean := False;
26412 Output_Seen
: Boolean := False;
26413 Proof_In_Seen
: Boolean := False;
26416 -- Process all the constituents of the state and note their modes
26417 -- within the global refinement.
26419 if Present
(Constits
) then
26420 Constit_Elmt
:= First_Elmt
(Constits
);
26421 while Present
(Constit_Elmt
) loop
26422 Constit_Id
:= Node
(Constit_Elmt
);
26424 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26425 Input_Seen
:= True;
26427 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
26428 In_Out_Seen
:= True;
26430 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26431 Output_Seen
:= True;
26433 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26435 Proof_In_Seen
:= True;
26438 Has_Missing
:= True;
26441 Next_Elmt
(Constit_Elmt
);
26445 -- An In_Out constituent is a valid completion
26447 if In_Out_Seen
then
26450 -- A pair of one Input/Proof_In and one Output constituent is a
26451 -- valid completion.
26453 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
26456 elsif Output_Seen
then
26458 -- A single Output constituent is a valid completion only when
26459 -- some of the other constituents are missing.
26461 if Has_Missing
then
26464 -- Otherwise all constituents are of mode Output
26468 ("global refinement of state & must include at least one "
26469 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26473 -- The state lacks a completion. When full refinement is visible,
26474 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26475 -- refinement is visible, emit an error if the abstract state
26476 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26477 -- both are utilized, Check_State_And_Constituent_Use. will issue
26480 elsif not Input_Seen
26481 and then not In_Out_Seen
26482 and then not Output_Seen
26483 and then not Proof_In_Seen
26485 if Has_Visible_Refinement
(State_Id
)
26486 or else Contains
(Repeat_Items
, State_Id
)
26489 ("missing global refinement of state &", N
, State_Id
);
26492 -- Otherwise the state has a malformed completion where at least
26493 -- one of the constituents has a different mode.
26497 ("global refinement of state & redefines the mode of its "
26498 & "constituents", N
, State_Id
);
26500 end Check_Constituent_Usage
;
26504 Item_Elmt
: Elmt_Id
;
26505 Item_Id
: Entity_Id
;
26507 -- Start of processing for Check_In_Out_States
26510 -- Do not perform this check in an instance because it was already
26511 -- performed successfully in the generic template.
26513 if Is_Generic_Instance
(Spec_Id
) then
26516 -- Inspect the In_Out items of the corresponding Global pragma
26517 -- looking for a state with a visible refinement.
26519 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
26520 Item_Elmt
:= First_Elmt
(In_Out_Items
);
26521 while Present
(Item_Elmt
) loop
26522 Item_Id
:= Node
(Item_Elmt
);
26524 -- Ensure that one of the three coverage variants is satisfied
26526 if Ekind
(Item_Id
) = E_Abstract_State
26527 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26529 Check_Constituent_Usage
(Item_Id
);
26532 Next_Elmt
(Item_Elmt
);
26535 end Check_In_Out_States
;
26537 ------------------------
26538 -- Check_Input_States --
26539 ------------------------
26541 procedure Check_Input_States
is
26542 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26543 -- Determine whether at least one constituent of state State_Id with
26544 -- full or partial visible refinement is used and has mode Input.
26545 -- Ensure that the remaining constituents do not have In_Out or
26546 -- Output modes. Emit an error if this is not the case
26547 -- (SPARK RM 7.2.4(5)).
26549 -----------------------------
26550 -- Check_Constituent_Usage --
26551 -----------------------------
26553 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26554 Constits
: constant Elist_Id
:=
26555 Partial_Refinement_Constituents
(State_Id
);
26556 Constit_Elmt
: Elmt_Id
;
26557 Constit_Id
: Entity_Id
;
26558 In_Seen
: Boolean := False;
26561 if Present
(Constits
) then
26562 Constit_Elmt
:= First_Elmt
(Constits
);
26563 while Present
(Constit_Elmt
) loop
26564 Constit_Id
:= Node
(Constit_Elmt
);
26566 -- At least one of the constituents appears as an Input
26568 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26571 -- A Proof_In constituent can refine an Input state as long
26572 -- as there is at least one Input constituent present.
26574 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26578 -- The constituent appears in the global refinement, but has
26579 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
26581 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26582 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26584 Error_Msg_Name_1
:= Chars
(State_Id
);
26586 ("constituent & of state % must have mode `Input` in "
26587 & "global refinement", N
, Constit_Id
);
26590 Next_Elmt
(Constit_Elmt
);
26594 -- Not one of the constituents appeared as Input. Always emit an
26595 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
26596 -- When only partial refinement is visible, emit an error if the
26597 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26598 -- the case where both are utilized, an error will be issued in
26599 -- Check_State_And_Constituent_Use.
26602 and then (Has_Visible_Refinement
(State_Id
)
26603 or else Contains
(Repeat_Items
, State_Id
))
26606 ("global refinement of state & must include at least one "
26607 & "constituent of mode `Input`", N
, State_Id
);
26609 end Check_Constituent_Usage
;
26613 Item_Elmt
: Elmt_Id
;
26614 Item_Id
: Entity_Id
;
26616 -- Start of processing for Check_Input_States
26619 -- Do not perform this check in an instance because it was already
26620 -- performed successfully in the generic template.
26622 if Is_Generic_Instance
(Spec_Id
) then
26625 -- Inspect the Input items of the corresponding Global pragma looking
26626 -- for a state with a visible refinement.
26628 elsif Has_In_State
and then Present
(In_Items
) then
26629 Item_Elmt
:= First_Elmt
(In_Items
);
26630 while Present
(Item_Elmt
) loop
26631 Item_Id
:= Node
(Item_Elmt
);
26633 -- When full refinement is visible, ensure that at least one of
26634 -- the constituents is utilized and is of mode Input. When only
26635 -- partial refinement is visible, ensure that either one of
26636 -- the constituents is utilized and is of mode Input, or the
26637 -- abstract state is repeated and no constituent is utilized.
26639 if Ekind
(Item_Id
) = E_Abstract_State
26640 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26642 Check_Constituent_Usage
(Item_Id
);
26645 Next_Elmt
(Item_Elmt
);
26648 end Check_Input_States
;
26650 -------------------------
26651 -- Check_Output_States --
26652 -------------------------
26654 procedure Check_Output_States
is
26655 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26656 -- Determine whether all constituents of state State_Id with full
26657 -- visible refinement are used and have mode Output. Emit an error
26658 -- if this is not the case (SPARK RM 7.2.4(5)).
26660 -----------------------------
26661 -- Check_Constituent_Usage --
26662 -----------------------------
26664 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26665 Constits
: constant Elist_Id
:=
26666 Partial_Refinement_Constituents
(State_Id
);
26667 Only_Partial
: constant Boolean :=
26668 not Has_Visible_Refinement
(State_Id
);
26669 Constit_Elmt
: Elmt_Id
;
26670 Constit_Id
: Entity_Id
;
26671 Posted
: Boolean := False;
26674 if Present
(Constits
) then
26675 Constit_Elmt
:= First_Elmt
(Constits
);
26676 while Present
(Constit_Elmt
) loop
26677 Constit_Id
:= Node
(Constit_Elmt
);
26679 -- Issue an error when a constituent of State_Id is utilized
26680 -- and State_Id has only partial visible refinement
26681 -- (SPARK RM 7.2.4(3d)).
26683 if Only_Partial
then
26684 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
26685 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
26687 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26689 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26691 Error_Msg_Name_1
:= Chars
(State_Id
);
26693 ("constituent & of state % cannot be used in global "
26694 & "refinement", N
, Constit_Id
);
26695 Error_Msg_Name_1
:= Chars
(State_Id
);
26696 SPARK_Msg_N
("\use state % instead", N
);
26699 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26702 -- The constituent appears in the global refinement, but has
26703 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
26705 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26706 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26707 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26709 Error_Msg_Name_1
:= Chars
(State_Id
);
26711 ("constituent & of state % must have mode `Output` in "
26712 & "global refinement", N
, Constit_Id
);
26714 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26720 ("`Output` state & must be replaced by all its "
26721 & "constituents in global refinement", N
, State_Id
);
26725 ("\constituent & is missing in output list",
26729 Next_Elmt
(Constit_Elmt
);
26732 end Check_Constituent_Usage
;
26736 Item_Elmt
: Elmt_Id
;
26737 Item_Id
: Entity_Id
;
26739 -- Start of processing for Check_Output_States
26742 -- Do not perform this check in an instance because it was already
26743 -- performed successfully in the generic template.
26745 if Is_Generic_Instance
(Spec_Id
) then
26748 -- Inspect the Output items of the corresponding Global pragma
26749 -- looking for a state with a visible refinement.
26751 elsif Has_Out_State
and then Present
(Out_Items
) then
26752 Item_Elmt
:= First_Elmt
(Out_Items
);
26753 while Present
(Item_Elmt
) loop
26754 Item_Id
:= Node
(Item_Elmt
);
26756 -- When full refinement is visible, ensure that all of the
26757 -- constituents are utilized and they have mode Output. When
26758 -- only partial refinement is visible, ensure that no
26759 -- constituent is utilized.
26761 if Ekind
(Item_Id
) = E_Abstract_State
26762 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26764 Check_Constituent_Usage
(Item_Id
);
26767 Next_Elmt
(Item_Elmt
);
26770 end Check_Output_States
;
26772 ---------------------------
26773 -- Check_Proof_In_States --
26774 ---------------------------
26776 procedure Check_Proof_In_States
is
26777 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26778 -- Determine whether at least one constituent of state State_Id with
26779 -- full or partial visible refinement is used and has mode Proof_In.
26780 -- Ensure that the remaining constituents do not have Input, In_Out,
26781 -- or Output modes. Emit an error if this is not the case
26782 -- (SPARK RM 7.2.4(5)).
26784 -----------------------------
26785 -- Check_Constituent_Usage --
26786 -----------------------------
26788 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26789 Constits
: constant Elist_Id
:=
26790 Partial_Refinement_Constituents
(State_Id
);
26791 Constit_Elmt
: Elmt_Id
;
26792 Constit_Id
: Entity_Id
;
26793 Proof_In_Seen
: Boolean := False;
26796 if Present
(Constits
) then
26797 Constit_Elmt
:= First_Elmt
(Constits
);
26798 while Present
(Constit_Elmt
) loop
26799 Constit_Id
:= Node
(Constit_Elmt
);
26801 -- At least one of the constituents appears as Proof_In
26803 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
26804 Proof_In_Seen
:= True;
26806 -- The constituent appears in the global refinement, but has
26807 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
26809 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26810 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26811 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26813 Error_Msg_Name_1
:= Chars
(State_Id
);
26815 ("constituent & of state % must have mode `Proof_In` "
26816 & "in global refinement", N
, Constit_Id
);
26819 Next_Elmt
(Constit_Elmt
);
26823 -- Not one of the constituents appeared as Proof_In. Always emit
26824 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
26825 -- When only partial refinement is visible, emit an error if the
26826 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26827 -- the case where both are utilized, an error will be issued by
26828 -- Check_State_And_Constituent_Use.
26830 if not Proof_In_Seen
26831 and then (Has_Visible_Refinement
(State_Id
)
26832 or else Contains
(Repeat_Items
, State_Id
))
26835 ("global refinement of state & must include at least one "
26836 & "constituent of mode `Proof_In`", N
, State_Id
);
26838 end Check_Constituent_Usage
;
26842 Item_Elmt
: Elmt_Id
;
26843 Item_Id
: Entity_Id
;
26845 -- Start of processing for Check_Proof_In_States
26848 -- Do not perform this check in an instance because it was already
26849 -- performed successfully in the generic template.
26851 if Is_Generic_Instance
(Spec_Id
) then
26854 -- Inspect the Proof_In items of the corresponding Global pragma
26855 -- looking for a state with a visible refinement.
26857 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
26858 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
26859 while Present
(Item_Elmt
) loop
26860 Item_Id
:= Node
(Item_Elmt
);
26862 -- Ensure that at least one of the constituents is utilized
26863 -- and is of mode Proof_In. When only partial refinement is
26864 -- visible, ensure that either one of the constituents is
26865 -- utilized and is of mode Proof_In, or the abstract state
26866 -- is repeated and no constituent is utilized.
26868 if Ekind
(Item_Id
) = E_Abstract_State
26869 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26871 Check_Constituent_Usage
(Item_Id
);
26874 Next_Elmt
(Item_Elmt
);
26877 end Check_Proof_In_States
;
26879 -------------------------------
26880 -- Check_Refined_Global_List --
26881 -------------------------------
26883 procedure Check_Refined_Global_List
26885 Global_Mode
: Name_Id
:= Name_Input
)
26887 procedure Check_Refined_Global_Item
26889 Global_Mode
: Name_Id
);
26890 -- Verify the legality of a single global item declaration. Parameter
26891 -- Global_Mode denotes the current mode in effect.
26893 -------------------------------
26894 -- Check_Refined_Global_Item --
26895 -------------------------------
26897 procedure Check_Refined_Global_Item
26899 Global_Mode
: Name_Id
)
26901 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
26903 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
26904 -- Issue a common error message for all mode mismatches. Expect
26905 -- denotes the expected mode.
26907 -----------------------------
26908 -- Inconsistent_Mode_Error --
26909 -----------------------------
26911 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
26914 ("global item & has inconsistent modes", Item
, Item_Id
);
26916 Error_Msg_Name_1
:= Global_Mode
;
26917 Error_Msg_Name_2
:= Expect
;
26918 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
26919 end Inconsistent_Mode_Error
;
26923 Enc_State
: Entity_Id
:= Empty
;
26924 -- Encapsulating state for constituent, Empty otherwise
26926 -- Start of processing for Check_Refined_Global_Item
26929 if Ekind_In
(Item_Id
, E_Abstract_State
,
26933 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
26936 -- When the state or object acts as a constituent of another
26937 -- state with a visible refinement, collect it for the state
26938 -- completeness checks performed later on. Note that the item
26939 -- acts as a constituent only when the encapsulating state is
26940 -- present in pragma Global.
26942 if Present
(Enc_State
)
26943 and then (Has_Visible_Refinement
(Enc_State
)
26944 or else Has_Partial_Visible_Refinement
(Enc_State
))
26945 and then Contains
(States
, Enc_State
)
26947 -- If the state has only partial visible refinement, remove it
26948 -- from the list of items that should be repeated from pragma
26951 if not Has_Visible_Refinement
(Enc_State
) then
26952 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26955 if Global_Mode
= Name_Input
then
26956 Append_New_Elmt
(Item_Id
, In_Constits
);
26958 elsif Global_Mode
= Name_In_Out
then
26959 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26961 elsif Global_Mode
= Name_Output
then
26962 Append_New_Elmt
(Item_Id
, Out_Constits
);
26964 elsif Global_Mode
= Name_Proof_In
then
26965 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
26968 -- When not a constituent, ensure that both occurrences of the
26969 -- item in pragmas Global and Refined_Global match. Also remove
26970 -- it when present from the list of items that should be repeated
26971 -- from pragma Global.
26974 Present_Then_Remove
(Repeat_Items
, Item_Id
);
26976 if Contains
(In_Items
, Item_Id
) then
26977 if Global_Mode
/= Name_Input
then
26978 Inconsistent_Mode_Error
(Name_Input
);
26981 elsif Contains
(In_Out_Items
, Item_Id
) then
26982 if Global_Mode
/= Name_In_Out
then
26983 Inconsistent_Mode_Error
(Name_In_Out
);
26986 elsif Contains
(Out_Items
, Item_Id
) then
26987 if Global_Mode
/= Name_Output
then
26988 Inconsistent_Mode_Error
(Name_Output
);
26991 elsif Contains
(Proof_In_Items
, Item_Id
) then
26994 -- The item does not appear in the corresponding Global pragma,
26995 -- it must be an extra (SPARK RM 7.2.4(3)).
26998 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
27001 end Check_Refined_Global_Item
;
27007 -- Start of processing for Check_Refined_Global_List
27010 -- Do not perform this check in an instance because it was already
27011 -- performed successfully in the generic template.
27013 if Is_Generic_Instance
(Spec_Id
) then
27016 elsif Nkind
(List
) = N_Null
then
27019 -- Single global item declaration
27021 elsif Nkind_In
(List
, N_Expanded_Name
,
27023 N_Selected_Component
)
27025 Check_Refined_Global_Item
(List
, Global_Mode
);
27027 -- Simple global list or moded global list declaration
27029 elsif Nkind
(List
) = N_Aggregate
then
27031 -- The declaration of a simple global list appear as a collection
27034 if Present
(Expressions
(List
)) then
27035 Item
:= First
(Expressions
(List
));
27036 while Present
(Item
) loop
27037 Check_Refined_Global_Item
(Item
, Global_Mode
);
27041 -- The declaration of a moded global list appears as a collection
27042 -- of component associations where individual choices denote
27045 elsif Present
(Component_Associations
(List
)) then
27046 Item
:= First
(Component_Associations
(List
));
27047 while Present
(Item
) loop
27048 Check_Refined_Global_List
27049 (List
=> Expression
(Item
),
27050 Global_Mode
=> Chars
(First
(Choices
(Item
))));
27058 raise Program_Error
;
27064 raise Program_Error
;
27066 end Check_Refined_Global_List
;
27068 --------------------------
27069 -- Collect_Global_Items --
27070 --------------------------
27072 procedure Collect_Global_Items
27074 Mode
: Name_Id
:= Name_Input
)
27076 procedure Collect_Global_Item
27078 Item_Mode
: Name_Id
);
27079 -- Add a single item to the appropriate list. Item_Mode denotes the
27080 -- current mode in effect.
27082 -------------------------
27083 -- Collect_Global_Item --
27084 -------------------------
27086 procedure Collect_Global_Item
27088 Item_Mode
: Name_Id
)
27090 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
27091 -- The above handles abstract views of variables and states built
27092 -- for limited with clauses.
27095 -- Signal that the global list contains at least one abstract
27096 -- state with a visible refinement. Note that the refinement may
27097 -- be null in which case there are no constituents.
27099 if Ekind
(Item_Id
) = E_Abstract_State
then
27100 if Has_Null_Visible_Refinement
(Item_Id
) then
27101 Has_Null_State
:= True;
27103 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27104 Append_New_Elmt
(Item_Id
, States
);
27106 if Item_Mode
= Name_Input
then
27107 Has_In_State
:= True;
27108 elsif Item_Mode
= Name_In_Out
then
27109 Has_In_Out_State
:= True;
27110 elsif Item_Mode
= Name_Output
then
27111 Has_Out_State
:= True;
27112 elsif Item_Mode
= Name_Proof_In
then
27113 Has_Proof_In_State
:= True;
27118 -- Record global items without full visible refinement found in
27119 -- pragma Global which should be repeated in the global refinement
27120 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27122 if Ekind
(Item_Id
) /= E_Abstract_State
27123 or else not Has_Visible_Refinement
(Item_Id
)
27125 Append_New_Elmt
(Item_Id
, Repeat_Items
);
27128 -- Add the item to the proper list
27130 if Item_Mode
= Name_Input
then
27131 Append_New_Elmt
(Item_Id
, In_Items
);
27132 elsif Item_Mode
= Name_In_Out
then
27133 Append_New_Elmt
(Item_Id
, In_Out_Items
);
27134 elsif Item_Mode
= Name_Output
then
27135 Append_New_Elmt
(Item_Id
, Out_Items
);
27136 elsif Item_Mode
= Name_Proof_In
then
27137 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
27139 end Collect_Global_Item
;
27145 -- Start of processing for Collect_Global_Items
27148 if Nkind
(List
) = N_Null
then
27151 -- Single global item declaration
27153 elsif Nkind_In
(List
, N_Expanded_Name
,
27155 N_Selected_Component
)
27157 Collect_Global_Item
(List
, Mode
);
27159 -- Single global list or moded global list declaration
27161 elsif Nkind
(List
) = N_Aggregate
then
27163 -- The declaration of a simple global list appear as a collection
27166 if Present
(Expressions
(List
)) then
27167 Item
:= First
(Expressions
(List
));
27168 while Present
(Item
) loop
27169 Collect_Global_Item
(Item
, Mode
);
27173 -- The declaration of a moded global list appears as a collection
27174 -- of component associations where individual choices denote mode.
27176 elsif Present
(Component_Associations
(List
)) then
27177 Item
:= First
(Component_Associations
(List
));
27178 while Present
(Item
) loop
27179 Collect_Global_Items
27180 (List
=> Expression
(Item
),
27181 Mode
=> Chars
(First
(Choices
(Item
))));
27189 raise Program_Error
;
27192 -- To accommodate partial decoration of disabled SPARK features, this
27193 -- routine may be called with illegal input. If this is the case, do
27194 -- not raise Program_Error.
27199 end Collect_Global_Items
;
27201 -------------------------
27202 -- Present_Then_Remove --
27203 -------------------------
27205 function Present_Then_Remove
27207 Item
: Entity_Id
) return Boolean
27212 if Present
(List
) then
27213 Elmt
:= First_Elmt
(List
);
27214 while Present
(Elmt
) loop
27215 if Node
(Elmt
) = Item
then
27216 Remove_Elmt
(List
, Elmt
);
27225 end Present_Then_Remove
;
27227 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
27230 Ignore
:= Present_Then_Remove
(List
, Item
);
27231 end Present_Then_Remove
;
27233 -------------------------------
27234 -- Report_Extra_Constituents --
27235 -------------------------------
27237 procedure Report_Extra_Constituents
is
27238 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
27239 -- Emit an error for every element of List
27241 ---------------------------------------
27242 -- Report_Extra_Constituents_In_List --
27243 ---------------------------------------
27245 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
27246 Constit_Elmt
: Elmt_Id
;
27249 if Present
(List
) then
27250 Constit_Elmt
:= First_Elmt
(List
);
27251 while Present
(Constit_Elmt
) loop
27252 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
27253 Next_Elmt
(Constit_Elmt
);
27256 end Report_Extra_Constituents_In_List
;
27258 -- Start of processing for Report_Extra_Constituents
27261 -- Do not perform this check in an instance because it was already
27262 -- performed successfully in the generic template.
27264 if Is_Generic_Instance
(Spec_Id
) then
27268 Report_Extra_Constituents_In_List
(In_Constits
);
27269 Report_Extra_Constituents_In_List
(In_Out_Constits
);
27270 Report_Extra_Constituents_In_List
(Out_Constits
);
27271 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
27273 end Report_Extra_Constituents
;
27275 --------------------------
27276 -- Report_Missing_Items --
27277 --------------------------
27279 procedure Report_Missing_Items
is
27280 Item_Elmt
: Elmt_Id
;
27281 Item_Id
: Entity_Id
;
27284 -- Do not perform this check in an instance because it was already
27285 -- performed successfully in the generic template.
27287 if Is_Generic_Instance
(Spec_Id
) then
27291 if Present
(Repeat_Items
) then
27292 Item_Elmt
:= First_Elmt
(Repeat_Items
);
27293 while Present
(Item_Elmt
) loop
27294 Item_Id
:= Node
(Item_Elmt
);
27295 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
27296 Next_Elmt
(Item_Elmt
);
27300 end Report_Missing_Items
;
27304 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27305 Errors
: constant Nat
:= Serious_Errors_Detected
;
27307 No_Constit
: Boolean;
27309 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
27312 -- Do not analyze the pragma multiple times
27314 if Is_Analyzed_Pragma
(N
) then
27318 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
27320 -- Use the anonymous object as the proper spec when Refined_Global
27321 -- applies to the body of a single task type. The object carries the
27322 -- proper Chars as well as all non-refined versions of pragmas.
27324 if Is_Single_Concurrent_Type
(Spec_Id
) then
27325 Spec_Id
:= Anonymous_Object
(Spec_Id
);
27328 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27329 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
27331 -- The subprogram declaration lacks pragma Global. This renders
27332 -- Refined_Global useless as there is nothing to refine.
27334 if No
(Global
) then
27336 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
27337 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
27341 -- Extract all relevant items from the corresponding Global pragma
27343 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27345 -- Package and subprogram bodies are instantiated individually in
27346 -- a separate compiler pass. Due to this mode of instantiation, the
27347 -- refinement of a state may no longer be visible when a subprogram
27348 -- body contract is instantiated. Since the generic template is legal,
27349 -- do not perform this check in the instance to circumvent this oddity.
27351 if Is_Generic_Instance
(Spec_Id
) then
27354 -- Non-instance case
27357 -- The corresponding Global pragma must mention at least one
27358 -- state with a visible refinement at the point Refined_Global
27359 -- is processed. States with null refinements need Refined_Global
27360 -- pragma (SPARK RM 7.2.4(2)).
27362 if not Has_In_State
27363 and then not Has_In_Out_State
27364 and then not Has_Out_State
27365 and then not Has_Proof_In_State
27366 and then not Has_Null_State
27369 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
27370 & "depend on abstract state with visible refinement"),
27374 -- The global refinement of inputs and outputs cannot be null when
27375 -- the corresponding Global pragma contains at least one item except
27376 -- in the case where we have states with null refinements.
27378 elsif Nkind
(Items
) = N_Null
27380 (Present
(In_Items
)
27381 or else Present
(In_Out_Items
)
27382 or else Present
(Out_Items
)
27383 or else Present
(Proof_In_Items
))
27384 and then not Has_Null_State
27387 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
27388 & "global items"), N
, Spec_Id
);
27393 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
27394 -- This ensures that the categorization of all refined global items is
27395 -- consistent with their role.
27397 Analyze_Global_In_Decl_Part
(N
);
27399 -- Perform all refinement checks with respect to completeness and mode
27402 if Serious_Errors_Detected
= Errors
then
27403 Check_Refined_Global_List
(Items
);
27406 -- Store the information that no constituent is used in the global
27407 -- refinement, prior to calling checking procedures which remove items
27408 -- from the list of constituents.
27412 and then No
(In_Out_Constits
)
27413 and then No
(Out_Constits
)
27414 and then No
(Proof_In_Constits
);
27416 -- For Input states with visible refinement, at least one constituent
27417 -- must be used as an Input in the global refinement.
27419 if Serious_Errors_Detected
= Errors
then
27420 Check_Input_States
;
27423 -- Verify all possible completion variants for In_Out states with
27424 -- visible refinement.
27426 if Serious_Errors_Detected
= Errors
then
27427 Check_In_Out_States
;
27430 -- For Output states with visible refinement, all constituents must be
27431 -- used as Outputs in the global refinement.
27433 if Serious_Errors_Detected
= Errors
then
27434 Check_Output_States
;
27437 -- For Proof_In states with visible refinement, at least one constituent
27438 -- must be used as Proof_In in the global refinement.
27440 if Serious_Errors_Detected
= Errors
then
27441 Check_Proof_In_States
;
27444 -- Emit errors for all constituents that belong to other states with
27445 -- visible refinement that do not appear in Global.
27447 if Serious_Errors_Detected
= Errors
then
27448 Report_Extra_Constituents
;
27451 -- Emit errors for all items in Global that are not repeated in the
27452 -- global refinement and for which there is no full visible refinement
27453 -- and, in the case of states with partial visible refinement, no
27454 -- constituent is mentioned in the global refinement.
27456 if Serious_Errors_Detected
= Errors
then
27457 Report_Missing_Items
;
27460 -- Emit an error if no constituent is used in the global refinement
27461 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27462 -- one may be issued by the checking procedures. Do not perform this
27463 -- check in an instance because it was already performed successfully
27464 -- in the generic template.
27466 if Serious_Errors_Detected
= Errors
27467 and then not Is_Generic_Instance
(Spec_Id
)
27468 and then not Has_Null_State
27469 and then No_Constit
27471 SPARK_Msg_N
("missing refinement", N
);
27475 Set_Is_Analyzed_Pragma
(N
);
27476 end Analyze_Refined_Global_In_Decl_Part
;
27478 ----------------------------------------
27479 -- Analyze_Refined_State_In_Decl_Part --
27480 ----------------------------------------
27482 procedure Analyze_Refined_State_In_Decl_Part
27484 Freeze_Id
: Entity_Id
:= Empty
)
27486 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
27487 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27488 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
27490 Available_States
: Elist_Id
:= No_Elist
;
27491 -- A list of all abstract states defined in the package declaration that
27492 -- are available for refinement. The list is used to report unrefined
27495 Body_States
: Elist_Id
:= No_Elist
;
27496 -- A list of all hidden states that appear in the body of the related
27497 -- package. The list is used to report unused hidden states.
27499 Constituents_Seen
: Elist_Id
:= No_Elist
;
27500 -- A list that contains all constituents processed so far. The list is
27501 -- used to detect multiple uses of the same constituent.
27503 Freeze_Posted
: Boolean := False;
27504 -- A flag that controls the output of a freezing-related error (see use
27507 Refined_States_Seen
: Elist_Id
:= No_Elist
;
27508 -- A list that contains all refined states processed so far. The list is
27509 -- used to detect duplicate refinements.
27511 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
27512 -- Perform full analysis of a single refinement clause
27514 procedure Report_Unrefined_States
(States
: Elist_Id
);
27515 -- Emit errors for all unrefined abstract states found in list States
27517 -------------------------------
27518 -- Analyze_Refinement_Clause --
27519 -------------------------------
27521 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
27522 AR_Constit
: Entity_Id
:= Empty
;
27523 AW_Constit
: Entity_Id
:= Empty
;
27524 ER_Constit
: Entity_Id
:= Empty
;
27525 EW_Constit
: Entity_Id
:= Empty
;
27526 -- The entities of external constituents that contain one of the
27527 -- following enabled properties: Async_Readers, Async_Writers,
27528 -- Effective_Reads and Effective_Writes.
27530 External_Constit_Seen
: Boolean := False;
27531 -- Flag used to mark when at least one external constituent is part
27532 -- of the state refinement.
27534 Non_Null_Seen
: Boolean := False;
27535 Null_Seen
: Boolean := False;
27536 -- Flags used to detect multiple uses of null in a single clause or a
27537 -- mixture of null and non-null constituents.
27539 Part_Of_Constits
: Elist_Id
:= No_Elist
;
27540 -- A list of all candidate constituents subject to indicator Part_Of
27541 -- where the encapsulating state is the current state.
27544 State_Id
: Entity_Id
;
27545 -- The current state being refined
27547 procedure Analyze_Constituent
(Constit
: Node_Id
);
27548 -- Perform full analysis of a single constituent
27550 procedure Check_External_Property
27551 (Prop_Nam
: Name_Id
;
27553 Constit
: Entity_Id
);
27554 -- Determine whether a property denoted by name Prop_Nam is present
27555 -- in the refined state. Emit an error if this is not the case. Flag
27556 -- Enabled should be set when the property applies to the refined
27557 -- state. Constit denotes the constituent (if any) which introduces
27558 -- the property in the refinement.
27560 procedure Match_State
;
27561 -- Determine whether the state being refined appears in list
27562 -- Available_States. Emit an error when attempting to re-refine the
27563 -- state or when the state is not defined in the package declaration,
27564 -- otherwise remove the state from Available_States.
27566 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
27567 -- Emit errors for all unused Part_Of constituents in list Constits
27569 -------------------------
27570 -- Analyze_Constituent --
27571 -------------------------
27573 procedure Analyze_Constituent
(Constit
: Node_Id
) is
27574 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
27575 -- Determine whether constituent Constit denoted by its entity
27576 -- Constit_Id appears in Body_States. Emit an error when the
27577 -- constituent is not a valid hidden state of the related package
27578 -- or when it is used more than once. Otherwise remove the
27579 -- constituent from Body_States.
27581 -----------------------
27582 -- Match_Constituent --
27583 -----------------------
27585 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
27586 procedure Collect_Constituent
;
27587 -- Verify the legality of constituent Constit_Id and add it to
27588 -- the refinements of State_Id.
27590 -------------------------
27591 -- Collect_Constituent --
27592 -------------------------
27594 procedure Collect_Constituent
is
27595 Constits
: Elist_Id
;
27598 -- The Ghost policy in effect at the point of abstract state
27599 -- declaration and constituent must match (SPARK RM 6.9(15))
27601 Check_Ghost_Refinement
27602 (State
, State_Id
, Constit
, Constit_Id
);
27604 -- A synchronized state must be refined by a synchronized
27605 -- object or another synchronized state (SPARK RM 9.6).
27607 if Is_Synchronized_State
(State_Id
)
27608 and then not Is_Synchronized_Object
(Constit_Id
)
27609 and then not Is_Synchronized_State
(Constit_Id
)
27612 ("constituent of synchronized state & must be "
27613 & "synchronized", Constit
, State_Id
);
27616 -- Add the constituent to the list of processed items to aid
27617 -- with the detection of duplicates.
27619 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
27621 -- Collect the constituent in the list of refinement items
27622 -- and establish a relation between the refined state and
27625 Constits
:= Refinement_Constituents
(State_Id
);
27627 if No
(Constits
) then
27628 Constits
:= New_Elmt_List
;
27629 Set_Refinement_Constituents
(State_Id
, Constits
);
27632 Append_Elmt
(Constit_Id
, Constits
);
27633 Set_Encapsulating_State
(Constit_Id
, State_Id
);
27635 -- The state has at least one legal constituent, mark the
27636 -- start of the refinement region. The region ends when the
27637 -- body declarations end (see routine Analyze_Declarations).
27639 Set_Has_Visible_Refinement
(State_Id
);
27641 -- When the constituent is external, save its relevant
27642 -- property for further checks.
27644 if Async_Readers_Enabled
(Constit_Id
) then
27645 AR_Constit
:= Constit_Id
;
27646 External_Constit_Seen
:= True;
27649 if Async_Writers_Enabled
(Constit_Id
) then
27650 AW_Constit
:= Constit_Id
;
27651 External_Constit_Seen
:= True;
27654 if Effective_Reads_Enabled
(Constit_Id
) then
27655 ER_Constit
:= Constit_Id
;
27656 External_Constit_Seen
:= True;
27659 if Effective_Writes_Enabled
(Constit_Id
) then
27660 EW_Constit
:= Constit_Id
;
27661 External_Constit_Seen
:= True;
27663 end Collect_Constituent
;
27667 State_Elmt
: Elmt_Id
;
27669 -- Start of processing for Match_Constituent
27672 -- Detect a duplicate use of a constituent
27674 if Contains
(Constituents_Seen
, Constit_Id
) then
27676 ("duplicate use of constituent &", Constit
, Constit_Id
);
27680 -- The constituent is subject to a Part_Of indicator
27682 if Present
(Encapsulating_State
(Constit_Id
)) then
27683 if Encapsulating_State
(Constit_Id
) = State_Id
then
27684 Remove
(Part_Of_Constits
, Constit_Id
);
27685 Collect_Constituent
;
27687 -- The constituent is part of another state and is used
27688 -- incorrectly in the refinement of the current state.
27691 Error_Msg_Name_1
:= Chars
(State_Id
);
27693 ("& cannot act as constituent of state %",
27694 Constit
, Constit_Id
);
27696 ("\Part_Of indicator specifies encapsulator &",
27697 Constit
, Encapsulating_State
(Constit_Id
));
27700 -- The only other source of legal constituents is the body
27701 -- state space of the related package.
27704 if Present
(Body_States
) then
27705 State_Elmt
:= First_Elmt
(Body_States
);
27706 while Present
(State_Elmt
) loop
27708 -- Consume a valid constituent to signal that it has
27709 -- been encountered.
27711 if Node
(State_Elmt
) = Constit_Id
then
27712 Remove_Elmt
(Body_States
, State_Elmt
);
27713 Collect_Constituent
;
27717 Next_Elmt
(State_Elmt
);
27721 -- At this point it is known that the constituent is not
27722 -- part of the package hidden state and cannot be used in
27723 -- a refinement (SPARK RM 7.2.2(9)).
27725 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27727 ("cannot use & in refinement, constituent is not a hidden "
27728 & "state of package %", Constit
, Constit_Id
);
27730 end Match_Constituent
;
27734 Constit_Id
: Entity_Id
;
27735 Constits
: Elist_Id
;
27737 -- Start of processing for Analyze_Constituent
27740 -- Detect multiple uses of null in a single refinement clause or a
27741 -- mixture of null and non-null constituents.
27743 if Nkind
(Constit
) = N_Null
then
27746 ("multiple null constituents not allowed", Constit
);
27748 elsif Non_Null_Seen
then
27750 ("cannot mix null and non-null constituents", Constit
);
27755 -- Collect the constituent in the list of refinement items
27757 Constits
:= Refinement_Constituents
(State_Id
);
27759 if No
(Constits
) then
27760 Constits
:= New_Elmt_List
;
27761 Set_Refinement_Constituents
(State_Id
, Constits
);
27764 Append_Elmt
(Constit
, Constits
);
27766 -- The state has at least one legal constituent, mark the
27767 -- start of the refinement region. The region ends when the
27768 -- body declarations end (see Analyze_Declarations).
27770 Set_Has_Visible_Refinement
(State_Id
);
27773 -- Non-null constituents
27776 Non_Null_Seen
:= True;
27780 ("cannot mix null and non-null constituents", Constit
);
27784 Resolve_State
(Constit
);
27786 -- Ensure that the constituent denotes a valid state or a
27787 -- whole object (SPARK RM 7.2.2(5)).
27789 if Is_Entity_Name
(Constit
) then
27790 Constit_Id
:= Entity_Of
(Constit
);
27792 -- When a constituent is declared after a subprogram body
27793 -- that caused freezing of the related contract where
27794 -- pragma Refined_State resides, the constituent appears
27795 -- undefined and carries Any_Id as its entity.
27797 -- package body Pack
27798 -- with Refined_State => (State => Constit)
27801 -- with Refined_Global => (Input => Constit)
27809 if Constit_Id
= Any_Id
then
27810 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
27812 -- Emit a specialized info message when the contract of
27813 -- the related package body was "frozen" by another body.
27814 -- Note that it is not possible to precisely identify why
27815 -- the constituent is undefined because it is not visible
27816 -- when pragma Refined_State is analyzed. This message is
27817 -- a reasonable approximation.
27819 if Present
(Freeze_Id
) and then not Freeze_Posted
then
27820 Freeze_Posted
:= True;
27822 Error_Msg_Name_1
:= Chars
(Body_Id
);
27823 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27825 ("body & declared # freezes the contract of %",
27828 ("\all constituents must be declared before body #",
27831 -- A misplaced constituent is a critical error because
27832 -- pragma Refined_Depends or Refined_Global depends on
27833 -- the proper link between a state and a constituent.
27834 -- Stop the compilation, as this leads to a multitude
27835 -- of misleading cascaded errors.
27837 raise Unrecoverable_Error
;
27840 -- The constituent is a valid state or object
27842 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
27846 Match_Constituent
(Constit_Id
);
27848 -- The variable may eventually become a constituent of a
27849 -- single protected/task type. Record the reference now
27850 -- and verify its legality when analyzing the contract of
27851 -- the variable (SPARK RM 9.3).
27853 if Ekind
(Constit_Id
) = E_Variable
then
27854 Record_Possible_Part_Of_Reference
27855 (Var_Id
=> Constit_Id
,
27859 -- Otherwise the constituent is illegal
27863 ("constituent & must denote object or state",
27864 Constit
, Constit_Id
);
27867 -- The constituent is illegal
27870 SPARK_Msg_N
("malformed constituent", Constit
);
27873 end Analyze_Constituent
;
27875 -----------------------------
27876 -- Check_External_Property --
27877 -----------------------------
27879 procedure Check_External_Property
27880 (Prop_Nam
: Name_Id
;
27882 Constit
: Entity_Id
)
27885 -- The property is missing in the declaration of the state, but
27886 -- a constituent is introducing it in the state refinement
27887 -- (SPARK RM 7.2.8(2)).
27889 if not Enabled
and then Present
(Constit
) then
27890 Error_Msg_Name_1
:= Prop_Nam
;
27891 Error_Msg_Name_2
:= Chars
(State_Id
);
27893 ("constituent & introduces external property % in refinement "
27894 & "of state %", State
, Constit
);
27896 Error_Msg_Sloc
:= Sloc
(State_Id
);
27898 ("\property is missing in abstract state declaration #",
27901 end Check_External_Property
;
27907 procedure Match_State
is
27908 State_Elmt
: Elmt_Id
;
27911 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27913 if Contains
(Refined_States_Seen
, State_Id
) then
27915 ("duplicate refinement of state &", State
, State_Id
);
27919 -- Inspect the abstract states defined in the package declaration
27920 -- looking for a match.
27922 State_Elmt
:= First_Elmt
(Available_States
);
27923 while Present
(State_Elmt
) loop
27925 -- A valid abstract state is being refined in the body. Add
27926 -- the state to the list of processed refined states to aid
27927 -- with the detection of duplicate refinements. Remove the
27928 -- state from Available_States to signal that it has already
27931 if Node
(State_Elmt
) = State_Id
then
27932 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
27933 Remove_Elmt
(Available_States
, State_Elmt
);
27937 Next_Elmt
(State_Elmt
);
27940 -- If we get here, we are refining a state that is not defined in
27941 -- the package declaration.
27943 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27945 ("cannot refine state, & is not defined in package %",
27949 --------------------------------
27950 -- Report_Unused_Constituents --
27951 --------------------------------
27953 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27954 Constit_Elmt
: Elmt_Id
;
27955 Constit_Id
: Entity_Id
;
27956 Posted
: Boolean := False;
27959 if Present
(Constits
) then
27960 Constit_Elmt
:= First_Elmt
(Constits
);
27961 while Present
(Constit_Elmt
) loop
27962 Constit_Id
:= Node
(Constit_Elmt
);
27964 -- Generate an error message of the form:
27966 -- state ... has unused Part_Of constituents
27967 -- abstract state ... defined at ...
27968 -- constant ... defined at ...
27969 -- variable ... defined at ...
27974 ("state & has unused Part_Of constituents",
27978 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
27980 if Ekind
(Constit_Id
) = E_Abstract_State
then
27982 ("\abstract state & defined #", State
, Constit_Id
);
27984 elsif Ekind
(Constit_Id
) = E_Constant
then
27986 ("\constant & defined #", State
, Constit_Id
);
27989 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
27990 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
27993 Next_Elmt
(Constit_Elmt
);
27996 end Report_Unused_Constituents
;
27998 -- Local declarations
28000 Body_Ref
: Node_Id
;
28001 Body_Ref_Elmt
: Elmt_Id
;
28003 Extra_State
: Node_Id
;
28005 -- Start of processing for Analyze_Refinement_Clause
28008 -- A refinement clause appears as a component association where the
28009 -- sole choice is the state and the expressions are the constituents.
28010 -- This is a syntax error, always report.
28012 if Nkind
(Clause
) /= N_Component_Association
then
28013 Error_Msg_N
("malformed state refinement clause", Clause
);
28017 -- Analyze the state name of a refinement clause
28019 State
:= First
(Choices
(Clause
));
28022 Resolve_State
(State
);
28024 -- Ensure that the state name denotes a valid abstract state that is
28025 -- defined in the spec of the related package.
28027 if Is_Entity_Name
(State
) then
28028 State_Id
:= Entity_Of
(State
);
28030 -- When the abstract state is undefined, it appears as Any_Id. Do
28031 -- not continue with the analysis of the clause.
28033 if State_Id
= Any_Id
then
28036 -- Catch any attempts to re-refine a state or refine a state that
28037 -- is not defined in the package declaration.
28039 elsif Ekind
(State_Id
) = E_Abstract_State
then
28043 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
28047 -- References to a state with visible refinement are illegal.
28048 -- When nested packages are involved, detecting such references is
28049 -- tricky because pragma Refined_State is analyzed later than the
28050 -- offending pragma Depends or Global. References that occur in
28051 -- such nested context are stored in a list. Emit errors for all
28052 -- references found in Body_References (SPARK RM 6.1.4(8)).
28054 if Present
(Body_References
(State_Id
)) then
28055 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
28056 while Present
(Body_Ref_Elmt
) loop
28057 Body_Ref
:= Node
(Body_Ref_Elmt
);
28059 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
28060 Error_Msg_Sloc
:= Sloc
(State
);
28061 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
28063 Next_Elmt
(Body_Ref_Elmt
);
28067 -- The state name is illegal. This is a syntax error, always report.
28070 Error_Msg_N
("malformed state name in refinement clause", State
);
28074 -- A refinement clause may only refine one state at a time
28076 Extra_State
:= Next
(State
);
28078 if Present
(Extra_State
) then
28080 ("refinement clause cannot cover multiple states", Extra_State
);
28083 -- Replicate the Part_Of constituents of the refined state because
28084 -- the algorithm will consume items.
28086 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
28088 -- Analyze all constituents of the refinement. Multiple constituents
28089 -- appear as an aggregate.
28091 Constit
:= Expression
(Clause
);
28093 if Nkind
(Constit
) = N_Aggregate
then
28094 if Present
(Component_Associations
(Constit
)) then
28096 ("constituents of refinement clause must appear in "
28097 & "positional form", Constit
);
28099 else pragma Assert
(Present
(Expressions
(Constit
)));
28100 Constit
:= First
(Expressions
(Constit
));
28101 while Present
(Constit
) loop
28102 Analyze_Constituent
(Constit
);
28107 -- Various forms of a single constituent. Note that these may include
28108 -- malformed constituents.
28111 Analyze_Constituent
(Constit
);
28114 -- Verify that external constituents do not introduce new external
28115 -- property in the state refinement (SPARK RM 7.2.8(2)).
28117 if Is_External_State
(State_Id
) then
28118 Check_External_Property
28119 (Prop_Nam
=> Name_Async_Readers
,
28120 Enabled
=> Async_Readers_Enabled
(State_Id
),
28121 Constit
=> AR_Constit
);
28123 Check_External_Property
28124 (Prop_Nam
=> Name_Async_Writers
,
28125 Enabled
=> Async_Writers_Enabled
(State_Id
),
28126 Constit
=> AW_Constit
);
28128 Check_External_Property
28129 (Prop_Nam
=> Name_Effective_Reads
,
28130 Enabled
=> Effective_Reads_Enabled
(State_Id
),
28131 Constit
=> ER_Constit
);
28133 Check_External_Property
28134 (Prop_Nam
=> Name_Effective_Writes
,
28135 Enabled
=> Effective_Writes_Enabled
(State_Id
),
28136 Constit
=> EW_Constit
);
28138 -- When a refined state is not external, it should not have external
28139 -- constituents (SPARK RM 7.2.8(1)).
28141 elsif External_Constit_Seen
then
28143 ("non-external state & cannot contain external constituents in "
28144 & "refinement", State
, State_Id
);
28147 -- Ensure that all Part_Of candidate constituents have been mentioned
28148 -- in the refinement clause.
28150 Report_Unused_Constituents
(Part_Of_Constits
);
28151 end Analyze_Refinement_Clause
;
28153 -----------------------------
28154 -- Report_Unrefined_States --
28155 -----------------------------
28157 procedure Report_Unrefined_States
(States
: Elist_Id
) is
28158 State_Elmt
: Elmt_Id
;
28161 if Present
(States
) then
28162 State_Elmt
:= First_Elmt
(States
);
28163 while Present
(State_Elmt
) loop
28165 ("abstract state & must be refined", Node
(State_Elmt
));
28167 Next_Elmt
(State_Elmt
);
28170 end Report_Unrefined_States
;
28172 -- Local declarations
28174 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
28177 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28180 -- Do not analyze the pragma multiple times
28182 if Is_Analyzed_Pragma
(N
) then
28186 -- Save the scenario for examination by the ABE Processing phase
28188 Record_Elaboration_Scenario
(N
);
28190 -- Replicate the abstract states declared by the package because the
28191 -- matching algorithm will consume states.
28193 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
28195 -- Gather all abstract states and objects declared in the visible
28196 -- state space of the package body. These items must be utilized as
28197 -- constituents in a state refinement.
28199 Body_States
:= Collect_Body_States
(Body_Id
);
28201 -- Multiple non-null state refinements appear as an aggregate
28203 if Nkind
(Clauses
) = N_Aggregate
then
28204 if Present
(Expressions
(Clauses
)) then
28206 ("state refinements must appear as component associations",
28209 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
28210 Clause
:= First
(Component_Associations
(Clauses
));
28211 while Present
(Clause
) loop
28212 Analyze_Refinement_Clause
(Clause
);
28217 -- Various forms of a single state refinement. Note that these may
28218 -- include malformed refinements.
28221 Analyze_Refinement_Clause
(Clauses
);
28224 -- List all abstract states that were left unrefined
28226 Report_Unrefined_States
(Available_States
);
28228 Set_Is_Analyzed_Pragma
(N
);
28229 end Analyze_Refined_State_In_Decl_Part
;
28231 ------------------------------------
28232 -- Analyze_Test_Case_In_Decl_Part --
28233 ------------------------------------
28235 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
28236 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28237 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28239 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
28240 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28241 -- denoted by Arg_Nam.
28243 ------------------------------
28244 -- Preanalyze_Test_Case_Arg --
28245 ------------------------------
28247 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
28251 -- Preanalyze the original aspect argument for ASIS or for a generic
28252 -- subprogram to properly capture global references.
28254 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
28258 Arg_Nam
=> Arg_Nam
,
28259 From_Aspect
=> True);
28261 if Present
(Arg
) then
28262 Preanalyze_Assert_Expression
28263 (Expression
(Arg
), Standard_Boolean
);
28267 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
28269 if Present
(Arg
) then
28270 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
28272 end Preanalyze_Test_Case_Arg
;
28276 Restore_Scope
: Boolean := False;
28278 -- Start of processing for Analyze_Test_Case_In_Decl_Part
28281 -- Do not analyze the pragma multiple times
28283 if Is_Analyzed_Pragma
(N
) then
28287 -- Ensure that the formal parameters are visible when analyzing all
28288 -- clauses. This falls out of the general rule of aspects pertaining
28289 -- to subprogram declarations.
28291 if not In_Open_Scopes
(Spec_Id
) then
28292 Restore_Scope
:= True;
28293 Push_Scope
(Spec_Id
);
28295 if Is_Generic_Subprogram
(Spec_Id
) then
28296 Install_Generic_Formals
(Spec_Id
);
28298 Install_Formals
(Spec_Id
);
28302 Preanalyze_Test_Case_Arg
(Name_Requires
);
28303 Preanalyze_Test_Case_Arg
(Name_Ensures
);
28305 if Restore_Scope
then
28309 -- Currently it is not possible to inline pre/postconditions on a
28310 -- subprogram subject to pragma Inline_Always.
28312 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
28314 Set_Is_Analyzed_Pragma
(N
);
28315 end Analyze_Test_Case_In_Decl_Part
;
28321 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
28326 if Present
(List
) then
28327 Elmt
:= First_Elmt
(List
);
28328 while Present
(Elmt
) loop
28329 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
28332 Id
:= Entity_Of
(Node
(Elmt
));
28335 if Id
= Item_Id
then
28346 -----------------------------------
28347 -- Build_Pragma_Check_Equivalent --
28348 -----------------------------------
28350 function Build_Pragma_Check_Equivalent
28352 Subp_Id
: Entity_Id
:= Empty
;
28353 Inher_Id
: Entity_Id
:= Empty
;
28354 Keep_Pragma_Id
: Boolean := False) return Node_Id
28356 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
28357 -- Detect whether node N references a formal parameter subject to
28358 -- pragma Unreferenced. If this is the case, set Comes_From_Source
28359 -- to False to suppress the generation of a reference when analyzing
28362 ------------------------
28363 -- Suppress_Reference --
28364 ------------------------
28366 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
28367 Formal
: Entity_Id
;
28370 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28371 Formal
:= Entity
(N
);
28373 -- The formal parameter is subject to pragma Unreferenced. Prevent
28374 -- the generation of references by resetting the Comes_From_Source
28377 if Is_Formal
(Formal
)
28378 and then Has_Pragma_Unreferenced
(Formal
)
28380 Set_Comes_From_Source
(N
, False);
28385 end Suppress_Reference
;
28387 procedure Suppress_References
is
28388 new Traverse_Proc
(Suppress_Reference
);
28392 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
28393 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28394 Check_Prag
: Node_Id
;
28398 Needs_Wrapper
: Boolean;
28399 pragma Unreferenced
(Needs_Wrapper
);
28401 -- Start of processing for Build_Pragma_Check_Equivalent
28404 -- When the pre- or postcondition is inherited, map the formals of the
28405 -- inherited subprogram to those of the current subprogram. In addition,
28406 -- map primitive operations of the parent type into the corresponding
28407 -- primitive operations of the descendant.
28409 if Present
(Inher_Id
) then
28410 pragma Assert
(Present
(Subp_Id
));
28412 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
28414 -- Use generic machinery to copy inherited pragma, as if it were an
28415 -- instantiation, resetting source locations appropriately, so that
28416 -- expressions inside the inherited pragma use chained locations.
28417 -- This is used in particular in GNATprove to locate precisely
28418 -- messages on a given inherited pragma.
28420 Set_Copied_Sloc_For_Inherited_Pragma
28421 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
28422 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28424 -- Build the inherited class-wide condition
28426 Build_Class_Wide_Expression
28427 (Prag
=> Check_Prag
,
28429 Par_Subp
=> Inher_Id
,
28430 Adjust_Sloc
=> True,
28431 Needs_Wrapper
=> Needs_Wrapper
);
28433 -- If not an inherited condition simply copy the original pragma
28436 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28439 -- Mark the pragma as being internally generated and reset the Analyzed
28442 Set_Analyzed
(Check_Prag
, False);
28443 Set_Comes_From_Source
(Check_Prag
, False);
28445 -- The tree of the original pragma may contain references to the
28446 -- formal parameters of the related subprogram. At the same time
28447 -- the corresponding body may mark the formals as unreferenced:
28449 -- procedure Proc (Formal : ...)
28450 -- with Pre => Formal ...;
28452 -- procedure Proc (Formal : ...) is
28453 -- pragma Unreferenced (Formal);
28456 -- This creates problems because all pragma Check equivalents are
28457 -- analyzed at the end of the body declarations. Since all source
28458 -- references have already been accounted for, reset any references
28459 -- to such formals in the generated pragma Check equivalent.
28461 Suppress_References
(Check_Prag
);
28463 if Present
(Corresponding_Aspect
(Prag
)) then
28464 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
28469 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28470 -- the copied pragma in the newly created pragma, convert the copy into
28471 -- pragma Check by correcting the name and adding a check_kind argument.
28473 if not Keep_Pragma_Id
then
28474 Set_Class_Present
(Check_Prag
, False);
28476 Set_Pragma_Identifier
28477 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
28479 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
28480 Make_Pragma_Argument_Association
(Loc
,
28481 Expression
=> Make_Identifier
(Loc
, Nam
)));
28484 -- Update the error message when the pragma is inherited
28486 if Present
(Inher_Id
) then
28487 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
28489 if Chars
(Msg_Arg
) = Name_Message
then
28490 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
28492 -- Insert "inherited" to improve the error message
28494 if Name_Buffer
(1 .. 8) = "failed p" then
28495 Insert_Str_In_Name_Buffer
("inherited ", 8);
28496 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
28502 end Build_Pragma_Check_Equivalent
;
28504 -----------------------------
28505 -- Check_Applicable_Policy --
28506 -----------------------------
28508 procedure Check_Applicable_Policy
(N
: Node_Id
) is
28512 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
28515 -- No effect if not valid assertion kind name
28517 if not Is_Valid_Assertion_Kind
(Ename
) then
28521 -- Loop through entries in check policy list
28523 PP
:= Opt
.Check_Policy_List
;
28524 while Present
(PP
) loop
28526 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28527 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28531 or else Pnm
= Name_Assertion
28532 or else (Pnm
= Name_Statement_Assertions
28533 and then Nam_In
(Ename
, Name_Assert
,
28534 Name_Assert_And_Cut
,
28536 Name_Loop_Invariant
,
28537 Name_Loop_Variant
))
28539 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
28545 -- In CodePeer mode and GNATprove mode, we need to
28546 -- consider all assertions, unless they are disabled.
28547 -- Force Is_Checked on ignored assertions, in particular
28548 -- because transformations of the AST may depend on
28549 -- assertions being checked (e.g. the translation of
28550 -- attribute 'Loop_Entry).
28552 if CodePeer_Mode
or GNATprove_Mode
then
28553 Set_Is_Checked
(N
, True);
28554 Set_Is_Ignored
(N
, False);
28556 Set_Is_Checked
(N
, False);
28557 Set_Is_Ignored
(N
, True);
28563 Set_Is_Checked
(N
, True);
28564 Set_Is_Ignored
(N
, False);
28566 when Name_Disable
=>
28567 Set_Is_Ignored
(N
, True);
28568 Set_Is_Checked
(N
, False);
28569 Set_Is_Disabled
(N
, True);
28571 -- That should be exhaustive, the null here is a defence
28572 -- against a malformed tree from previous errors.
28581 PP
:= Next_Pragma
(PP
);
28585 -- If there are no specific entries that matched, then we let the
28586 -- setting of assertions govern. Note that this provides the needed
28587 -- compatibility with the RM for the cases of assertion, invariant,
28588 -- precondition, predicate, and postcondition. Note also that
28589 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
28591 if Assertions_Enabled
then
28592 Set_Is_Checked
(N
, True);
28593 Set_Is_Ignored
(N
, False);
28595 Set_Is_Checked
(N
, False);
28596 Set_Is_Ignored
(N
, True);
28598 end Check_Applicable_Policy
;
28600 -------------------------------
28601 -- Check_External_Properties --
28602 -------------------------------
28604 procedure Check_External_Properties
28612 -- All properties enabled
28614 if AR
and AW
and ER
and EW
then
28617 -- Async_Readers + Effective_Writes
28618 -- Async_Readers + Async_Writers + Effective_Writes
28620 elsif AR
and EW
and not ER
then
28623 -- Async_Writers + Effective_Reads
28624 -- Async_Readers + Async_Writers + Effective_Reads
28626 elsif AW
and ER
and not EW
then
28629 -- Async_Readers + Async_Writers
28631 elsif AR
and AW
and not ER
and not EW
then
28636 elsif AR
and not AW
and not ER
and not EW
then
28641 elsif AW
and not AR
and not ER
and not EW
then
28646 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
28649 end Check_External_Properties
;
28655 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
28659 -- Loop through entries in check policy list
28661 PP
:= Opt
.Check_Policy_List
;
28662 while Present
(PP
) loop
28664 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28665 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28669 or else (Pnm
= Name_Assertion
28670 and then Is_Valid_Assertion_Kind
(Nam
))
28671 or else (Pnm
= Name_Statement_Assertions
28672 and then Nam_In
(Nam
, Name_Assert
,
28673 Name_Assert_And_Cut
,
28675 Name_Loop_Invariant
,
28676 Name_Loop_Variant
))
28678 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
28687 return Name_Ignore
;
28689 when Name_Disable
=>
28690 return Name_Disable
;
28693 raise Program_Error
;
28697 PP
:= Next_Pragma
(PP
);
28702 -- If there are no specific entries that matched, then we let the
28703 -- setting of assertions govern. Note that this provides the needed
28704 -- compatibility with the RM for the cases of assertion, invariant,
28705 -- precondition, predicate, and postcondition.
28707 if Assertions_Enabled
then
28710 return Name_Ignore
;
28714 ---------------------------
28715 -- Check_Missing_Part_Of --
28716 ---------------------------
28718 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
28719 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
28720 -- Determine whether a package denoted by Pack_Id declares at least one
28723 -----------------------
28724 -- Has_Visible_State --
28725 -----------------------
28727 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
28728 Item_Id
: Entity_Id
;
28731 -- Traverse the entity chain of the package trying to find at least
28732 -- one visible abstract state, variable or a package [instantiation]
28733 -- that declares a visible state.
28735 Item_Id
:= First_Entity
(Pack_Id
);
28736 while Present
(Item_Id
)
28737 and then not In_Private_Part
(Item_Id
)
28739 -- Do not consider internally generated items
28741 if not Comes_From_Source
(Item_Id
) then
28744 -- A visible state has been found
28746 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
28749 -- Recursively peek into nested packages and instantiations
28751 elsif Ekind
(Item_Id
) = E_Package
28752 and then Has_Visible_State
(Item_Id
)
28757 Next_Entity
(Item_Id
);
28761 end Has_Visible_State
;
28765 Pack_Id
: Entity_Id
;
28766 Placement
: State_Space_Kind
;
28768 -- Start of processing for Check_Missing_Part_Of
28771 -- Do not consider abstract states, variables or package instantiations
28772 -- coming from an instance as those always inherit the Part_Of indicator
28773 -- of the instance itself.
28775 if In_Instance
then
28778 -- Do not consider internally generated entities as these can never
28779 -- have a Part_Of indicator.
28781 elsif not Comes_From_Source
(Item_Id
) then
28784 -- Perform these checks only when SPARK_Mode is enabled as they will
28785 -- interfere with standard Ada rules and produce false positives.
28787 elsif SPARK_Mode
/= On
then
28790 -- Do not consider constants, because the compiler cannot accurately
28791 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
28792 -- act as a hidden state of a package.
28794 elsif Ekind
(Item_Id
) = E_Constant
then
28798 -- Find where the abstract state, variable or package instantiation
28799 -- lives with respect to the state space.
28801 Find_Placement_In_State_Space
28802 (Item_Id
=> Item_Id
,
28803 Placement
=> Placement
,
28804 Pack_Id
=> Pack_Id
);
28806 -- Items that appear in a non-package construct (subprogram, block, etc)
28807 -- do not require a Part_Of indicator because they can never act as a
28810 if Placement
= Not_In_Package
then
28813 -- An item declared in the body state space of a package always act as a
28814 -- constituent and does not need explicit Part_Of indicator.
28816 elsif Placement
= Body_State_Space
then
28819 -- In general an item declared in the visible state space of a package
28820 -- does not require a Part_Of indicator. The only exception is when the
28821 -- related package is a private child unit in which case Part_Of must
28822 -- denote a state in the parent unit or in one of its descendants.
28824 elsif Placement
= Visible_State_Space
then
28825 if Is_Child_Unit
(Pack_Id
)
28826 and then Is_Private_Descendant
(Pack_Id
)
28828 -- A package instantiation does not need a Part_Of indicator when
28829 -- the related generic template has no visible state.
28831 if Ekind
(Item_Id
) = E_Package
28832 and then Is_Generic_Instance
(Item_Id
)
28833 and then not Has_Visible_State
(Item_Id
)
28837 -- All other cases require Part_Of
28841 ("indicator Part_Of is required in this context "
28842 & "(SPARK RM 7.2.6(3))", Item_Id
);
28843 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28845 ("\& is declared in the visible part of private child "
28846 & "unit %", Item_Id
);
28850 -- When the item appears in the private state space of a package, it
28851 -- must be a part of some state declared by the said package.
28853 else pragma Assert
(Placement
= Private_State_Space
);
28855 -- The related package does not declare a state, the item cannot act
28856 -- as a Part_Of constituent.
28858 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
28861 -- A package instantiation does not need a Part_Of indicator when the
28862 -- related generic template has no visible state.
28864 elsif Ekind
(Pack_Id
) = E_Package
28865 and then Is_Generic_Instance
(Pack_Id
)
28866 and then not Has_Visible_State
(Pack_Id
)
28870 -- All other cases require Part_Of
28874 ("indicator Part_Of is required in this context "
28875 & "(SPARK RM 7.2.6(2))", Item_Id
);
28876 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28878 ("\& is declared in the private part of package %", Item_Id
);
28881 end Check_Missing_Part_Of
;
28883 ---------------------------------------------------
28884 -- Check_Postcondition_Use_In_Inlined_Subprogram --
28885 ---------------------------------------------------
28887 procedure Check_Postcondition_Use_In_Inlined_Subprogram
28889 Spec_Id
: Entity_Id
)
28892 if Warn_On_Redundant_Constructs
28893 and then Has_Pragma_Inline_Always
(Spec_Id
)
28894 and then Assertions_Enabled
28896 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28898 if From_Aspect_Specification
(Prag
) then
28900 ("aspect % not enforced on inlined subprogram &?r?",
28901 Corresponding_Aspect
(Prag
), Spec_Id
);
28904 ("pragma % not enforced on inlined subprogram &?r?",
28908 end Check_Postcondition_Use_In_Inlined_Subprogram
;
28910 -------------------------------------
28911 -- Check_State_And_Constituent_Use --
28912 -------------------------------------
28914 procedure Check_State_And_Constituent_Use
28915 (States
: Elist_Id
;
28916 Constits
: Elist_Id
;
28919 Constit_Elmt
: Elmt_Id
;
28920 Constit_Id
: Entity_Id
;
28921 State_Id
: Entity_Id
;
28924 -- Nothing to do if there are no states or constituents
28926 if No
(States
) or else No
(Constits
) then
28930 -- Inspect the list of constituents and try to determine whether its
28931 -- encapsulating state is in list States.
28933 Constit_Elmt
:= First_Elmt
(Constits
);
28934 while Present
(Constit_Elmt
) loop
28935 Constit_Id
:= Node
(Constit_Elmt
);
28937 -- Determine whether the constituent is part of an encapsulating
28938 -- state that appears in the same context and if this is the case,
28939 -- emit an error (SPARK RM 7.2.6(7)).
28941 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
28943 if Present
(State_Id
) then
28944 Error_Msg_Name_1
:= Chars
(Constit_Id
);
28946 ("cannot mention state & and its constituent % in the same "
28947 & "context", Context
, State_Id
);
28951 Next_Elmt
(Constit_Elmt
);
28953 end Check_State_And_Constituent_Use
;
28955 ---------------------------------------------
28956 -- Collect_Inherited_Class_Wide_Conditions --
28957 ---------------------------------------------
28959 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28960 Parent_Subp
: constant Entity_Id
:=
28961 Ultimate_Alias
(Overridden_Operation
(Subp
));
28962 -- The Overridden_Operation may itself be inherited and as such have no
28963 -- explicit contract.
28965 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
28966 In_Spec_Expr
: Boolean;
28967 Installed
: Boolean;
28969 New_Prag
: Node_Id
;
28972 Installed
:= False;
28974 -- Iterate over the contract of the overridden subprogram to find all
28975 -- inherited class-wide pre- and postconditions.
28977 if Present
(Prags
) then
28978 Prag
:= Pre_Post_Conditions
(Prags
);
28980 while Present
(Prag
) loop
28981 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
28982 Name_Precondition
, Name_Postcondition
)
28983 and then Class_Present
(Prag
)
28985 -- The generated pragma must be analyzed in the context of
28986 -- the subprogram, to make its formals visible. In addition,
28987 -- we must inhibit freezing and full analysis because the
28988 -- controlling type of the subprogram is not frozen yet, and
28989 -- may have further primitives.
28991 if not Installed
then
28994 Install_Formals
(Subp
);
28995 In_Spec_Expr
:= In_Spec_Expression
;
28996 In_Spec_Expression
:= True;
29000 Build_Pragma_Check_Equivalent
29001 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
29003 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
29004 Preanalyze
(New_Prag
);
29006 -- Prevent further analysis in subsequent processing of the
29007 -- current list of declarations
29009 Set_Analyzed
(New_Prag
);
29012 Prag
:= Next_Pragma
(Prag
);
29016 In_Spec_Expression
:= In_Spec_Expr
;
29020 end Collect_Inherited_Class_Wide_Conditions
;
29022 ---------------------------------------
29023 -- Collect_Subprogram_Inputs_Outputs --
29024 ---------------------------------------
29026 procedure Collect_Subprogram_Inputs_Outputs
29027 (Subp_Id
: Entity_Id
;
29028 Synthesize
: Boolean := False;
29029 Subp_Inputs
: in out Elist_Id
;
29030 Subp_Outputs
: in out Elist_Id
;
29031 Global_Seen
: out Boolean)
29033 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
29034 -- Collect all relevant items from a dependency clause
29036 procedure Collect_Global_List
29038 Mode
: Name_Id
:= Name_Input
);
29039 -- Collect all relevant items from a global list
29041 -------------------------------
29042 -- Collect_Dependency_Clause --
29043 -------------------------------
29045 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
29046 procedure Collect_Dependency_Item
29048 Is_Input
: Boolean);
29049 -- Add an item to the proper subprogram input or output collection
29051 -----------------------------
29052 -- Collect_Dependency_Item --
29053 -----------------------------
29055 procedure Collect_Dependency_Item
29057 Is_Input
: Boolean)
29062 -- Nothing to collect when the item is null
29064 if Nkind
(Item
) = N_Null
then
29067 -- Ditto for attribute 'Result
29069 elsif Is_Attribute_Result
(Item
) then
29072 -- Multiple items appear as an aggregate
29074 elsif Nkind
(Item
) = N_Aggregate
then
29075 Extra
:= First
(Expressions
(Item
));
29076 while Present
(Extra
) loop
29077 Collect_Dependency_Item
(Extra
, Is_Input
);
29081 -- Otherwise this is a solitary item
29085 Append_New_Elmt
(Item
, Subp_Inputs
);
29087 Append_New_Elmt
(Item
, Subp_Outputs
);
29090 end Collect_Dependency_Item
;
29092 -- Start of processing for Collect_Dependency_Clause
29095 if Nkind
(Clause
) = N_Null
then
29098 -- A dependency clause appears as component association
29100 elsif Nkind
(Clause
) = N_Component_Association
then
29101 Collect_Dependency_Item
29102 (Item
=> Expression
(Clause
),
29105 Collect_Dependency_Item
29106 (Item
=> First
(Choices
(Clause
)),
29107 Is_Input
=> False);
29109 -- To accommodate partial decoration of disabled SPARK features, this
29110 -- routine may be called with illegal input. If this is the case, do
29111 -- not raise Program_Error.
29116 end Collect_Dependency_Clause
;
29118 -------------------------
29119 -- Collect_Global_List --
29120 -------------------------
29122 procedure Collect_Global_List
29124 Mode
: Name_Id
:= Name_Input
)
29126 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
29127 -- Add an item to the proper subprogram input or output collection
29129 -------------------------
29130 -- Collect_Global_Item --
29131 -------------------------
29133 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
29135 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
29136 Append_New_Elmt
(Item
, Subp_Inputs
);
29139 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
29140 Append_New_Elmt
(Item
, Subp_Outputs
);
29142 end Collect_Global_Item
;
29149 -- Start of processing for Collect_Global_List
29152 if Nkind
(List
) = N_Null
then
29155 -- Single global item declaration
29157 elsif Nkind_In
(List
, N_Expanded_Name
,
29159 N_Selected_Component
)
29161 Collect_Global_Item
(List
, Mode
);
29163 -- Simple global list or moded global list declaration
29165 elsif Nkind
(List
) = N_Aggregate
then
29166 if Present
(Expressions
(List
)) then
29167 Item
:= First
(Expressions
(List
));
29168 while Present
(Item
) loop
29169 Collect_Global_Item
(Item
, Mode
);
29174 Assoc
:= First
(Component_Associations
(List
));
29175 while Present
(Assoc
) loop
29176 Collect_Global_List
29177 (List
=> Expression
(Assoc
),
29178 Mode
=> Chars
(First
(Choices
(Assoc
))));
29183 -- To accommodate partial decoration of disabled SPARK features, this
29184 -- routine may be called with illegal input. If this is the case, do
29185 -- not raise Program_Error.
29190 end Collect_Global_List
;
29197 Formal
: Entity_Id
;
29199 Spec_Id
: Entity_Id
:= Empty
;
29200 Subp_Decl
: Node_Id
;
29203 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29206 Global_Seen
:= False;
29208 -- Process all formal parameters of entries, [generic] subprograms, and
29211 if Ekind_In
(Subp_Id
, E_Entry
,
29214 E_Generic_Function
,
29215 E_Generic_Procedure
,
29219 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
29220 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29222 -- Process all formal parameters
29224 Formal
:= First_Entity
(Spec_Id
);
29225 while Present
(Formal
) loop
29226 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
29227 Append_New_Elmt
(Formal
, Subp_Inputs
);
29230 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
29231 Append_New_Elmt
(Formal
, Subp_Outputs
);
29233 -- Out parameters can act as inputs when the related type is
29234 -- tagged, unconstrained array, unconstrained record, or record
29235 -- with unconstrained components.
29237 if Ekind
(Formal
) = E_Out_Parameter
29238 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
29240 Append_New_Elmt
(Formal
, Subp_Inputs
);
29244 Next_Entity
(Formal
);
29247 -- Otherwise the input denotes a task type, a task body, or the
29248 -- anonymous object created for a single task type.
29250 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
29251 or else Is_Single_Task_Object
(Subp_Id
)
29253 Subp_Decl
:= Declaration_Node
(Subp_Id
);
29254 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29257 -- When processing an entry, subprogram or task body, look for pragmas
29258 -- Refined_Depends and Refined_Global as they specify the inputs and
29261 if Is_Entry_Body
(Subp_Id
)
29262 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
29264 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
29265 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
29267 -- Subprogram declaration or stand-alone body case, look for pragmas
29268 -- Depends and Global
29271 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
29272 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
29275 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
29276 -- because it provides finer granularity of inputs and outputs.
29278 if Present
(Global
) then
29279 Global_Seen
:= True;
29280 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
29282 -- When the related subprogram lacks pragma [Refined_]Global, fall back
29283 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
29284 -- the inputs and outputs from [Refined_]Depends.
29286 elsif Synthesize
and then Present
(Depends
) then
29287 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
29289 -- Multiple dependency clauses appear as an aggregate
29291 if Nkind
(Clauses
) = N_Aggregate
then
29292 Clause
:= First
(Component_Associations
(Clauses
));
29293 while Present
(Clause
) loop
29294 Collect_Dependency_Clause
(Clause
);
29298 -- Otherwise this is a single dependency clause
29301 Collect_Dependency_Clause
(Clauses
);
29305 -- The current instance of a protected type acts as a formal parameter
29306 -- of mode IN for functions and IN OUT for entries and procedures
29307 -- (SPARK RM 6.1.4).
29309 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
29310 Typ
:= Scope
(Spec_Id
);
29312 -- Use the anonymous object when the type is single protected
29314 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
29315 Typ
:= Anonymous_Object
(Typ
);
29318 Append_New_Elmt
(Typ
, Subp_Inputs
);
29320 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
29321 Append_New_Elmt
(Typ
, Subp_Outputs
);
29324 -- The current instance of a task type acts as a formal parameter of
29325 -- mode IN OUT (SPARK RM 6.1.4).
29327 elsif Ekind
(Spec_Id
) = E_Task_Type
then
29330 -- Use the anonymous object when the type is single task
29332 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
29333 Typ
:= Anonymous_Object
(Typ
);
29336 Append_New_Elmt
(Typ
, Subp_Inputs
);
29337 Append_New_Elmt
(Typ
, Subp_Outputs
);
29339 elsif Is_Single_Task_Object
(Spec_Id
) then
29340 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
29341 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
29343 end Collect_Subprogram_Inputs_Outputs
;
29345 ---------------------------
29346 -- Contract_Freeze_Error --
29347 ---------------------------
29349 procedure Contract_Freeze_Error
29350 (Contract_Id
: Entity_Id
;
29351 Freeze_Id
: Entity_Id
)
29354 Error_Msg_Name_1
:= Chars
(Contract_Id
);
29355 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
29358 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
29360 ("\all contractual items must be declared before body #", Contract_Id
);
29361 end Contract_Freeze_Error
;
29363 ---------------------------------
29364 -- Delay_Config_Pragma_Analyze --
29365 ---------------------------------
29367 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
29369 return Nam_In
(Pragma_Name_Unmapped
(N
),
29370 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
29371 end Delay_Config_Pragma_Analyze
;
29373 -----------------------
29374 -- Duplication_Error --
29375 -----------------------
29377 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
29378 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
29379 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
29382 Error_Msg_Sloc
:= Sloc
(Prev
);
29383 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
29385 -- Emit a precise message to distinguish between source pragmas and
29386 -- pragmas generated from aspects. The ordering of the two pragmas is
29390 -- Prag -- duplicate
29392 -- No error is emitted when both pragmas come from aspects because this
29393 -- is already detected by the general aspect analysis mechanism.
29395 if Prag_From_Asp
and Prev_From_Asp
then
29397 elsif Prag_From_Asp
then
29398 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
29399 elsif Prev_From_Asp
then
29400 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
29402 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
29404 end Duplication_Error
;
29406 ------------------------------
29407 -- Find_Encapsulating_State --
29408 ------------------------------
29410 function Find_Encapsulating_State
29411 (States
: Elist_Id
;
29412 Constit_Id
: Entity_Id
) return Entity_Id
29414 State_Id
: Entity_Id
;
29417 -- Since a constituent may be part of a larger constituent set, climb
29418 -- the encapsulating state chain looking for a state that appears in
29421 State_Id
:= Encapsulating_State
(Constit_Id
);
29422 while Present
(State_Id
) loop
29423 if Contains
(States
, State_Id
) then
29427 State_Id
:= Encapsulating_State
(State_Id
);
29431 end Find_Encapsulating_State
;
29433 --------------------------
29434 -- Find_Related_Context --
29435 --------------------------
29437 function Find_Related_Context
29439 Do_Checks
: Boolean := False) return Node_Id
29444 Stmt
:= Prev
(Prag
);
29445 while Present
(Stmt
) loop
29447 -- Skip prior pragmas, but check for duplicates
29449 if Nkind
(Stmt
) = N_Pragma
then
29451 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
29458 -- Skip internally generated code
29460 elsif not Comes_From_Source
(Stmt
) then
29462 -- The anonymous object created for a single concurrent type is a
29463 -- suitable context.
29465 if Nkind
(Stmt
) = N_Object_Declaration
29466 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29471 -- Return the current source construct
29481 end Find_Related_Context
;
29483 --------------------------------------
29484 -- Find_Related_Declaration_Or_Body --
29485 --------------------------------------
29487 function Find_Related_Declaration_Or_Body
29489 Do_Checks
: Boolean := False) return Node_Id
29491 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
29493 procedure Expression_Function_Error
;
29494 -- Emit an error concerning pragma Prag that illegaly applies to an
29495 -- expression function.
29497 -------------------------------
29498 -- Expression_Function_Error --
29499 -------------------------------
29501 procedure Expression_Function_Error
is
29503 Error_Msg_Name_1
:= Prag_Nam
;
29505 -- Emit a precise message to distinguish between source pragmas and
29506 -- pragmas generated from aspects.
29508 if From_Aspect_Specification
(Prag
) then
29510 ("aspect % cannot apply to a stand alone expression function",
29514 ("pragma % cannot apply to a stand alone expression function",
29517 end Expression_Function_Error
;
29521 Context
: constant Node_Id
:= Parent
(Prag
);
29524 Look_For_Body
: constant Boolean :=
29525 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
29526 Name_Refined_Global
,
29528 Name_Refined_State
);
29529 -- Refinement pragmas must be associated with a subprogram body [stub]
29531 -- Start of processing for Find_Related_Declaration_Or_Body
29534 Stmt
:= Prev
(Prag
);
29535 while Present
(Stmt
) loop
29537 -- Skip prior pragmas, but check for duplicates. Pragmas produced
29538 -- by splitting a complex pre/postcondition are not considered to
29541 if Nkind
(Stmt
) = N_Pragma
then
29543 and then not Split_PPC
(Stmt
)
29544 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
29551 -- Emit an error when a refinement pragma appears on an expression
29552 -- function without a completion.
29555 and then Look_For_Body
29556 and then Nkind
(Stmt
) = N_Subprogram_Declaration
29557 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
29558 and then not Has_Completion
(Defining_Entity
(Stmt
))
29560 Expression_Function_Error
;
29563 -- The refinement pragma applies to a subprogram body stub
29565 elsif Look_For_Body
29566 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
29570 -- Skip internally generated code
29572 elsif not Comes_From_Source
(Stmt
) then
29574 -- The anonymous object created for a single concurrent type is a
29575 -- suitable context.
29577 if Nkind
(Stmt
) = N_Object_Declaration
29578 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29582 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
29584 -- The subprogram declaration is an internally generated spec
29585 -- for an expression function.
29587 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29590 -- The subprogram is actually an instance housed within an
29591 -- anonymous wrapper package.
29593 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29598 -- Return the current construct which is either a subprogram body,
29599 -- a subprogram declaration or is illegal.
29608 -- If we fall through, then the pragma was either the first declaration
29609 -- or it was preceded by other pragmas and no source constructs.
29611 -- The pragma is associated with a library-level subprogram
29613 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
29614 return Unit
(Parent
(Context
));
29616 -- The pragma appears inside the declarations of an entry body
29618 elsif Nkind
(Context
) = N_Entry_Body
then
29621 -- The pragma appears inside the statements of a subprogram body. This
29622 -- placement is the result of subprogram contract expansion.
29624 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
29625 return Parent
(Context
);
29627 -- The pragma appears inside the declarative part of a package body
29629 elsif Nkind
(Context
) = N_Package_Body
then
29632 -- The pragma appears inside the declarative part of a subprogram body
29634 elsif Nkind
(Context
) = N_Subprogram_Body
then
29637 -- The pragma appears inside the declarative part of a task body
29639 elsif Nkind
(Context
) = N_Task_Body
then
29642 -- The pragma appears inside the visible part of a package specification
29644 elsif Nkind
(Context
) = N_Package_Specification
then
29645 return Parent
(Context
);
29647 -- The pragma is a byproduct of aspect expansion, return the related
29648 -- context of the original aspect. This case has a lower priority as
29649 -- the above circuitry pinpoints precisely the related context.
29651 elsif Present
(Corresponding_Aspect
(Prag
)) then
29652 return Parent
(Corresponding_Aspect
(Prag
));
29654 -- No candidate subprogram [body] found
29659 end Find_Related_Declaration_Or_Body
;
29661 ----------------------------------
29662 -- Find_Related_Package_Or_Body --
29663 ----------------------------------
29665 function Find_Related_Package_Or_Body
29667 Do_Checks
: Boolean := False) return Node_Id
29669 Context
: constant Node_Id
:= Parent
(Prag
);
29670 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29674 Stmt
:= Prev
(Prag
);
29675 while Present
(Stmt
) loop
29677 -- Skip prior pragmas, but check for duplicates
29679 if Nkind
(Stmt
) = N_Pragma
then
29680 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
29686 -- Skip internally generated code
29688 elsif not Comes_From_Source
(Stmt
) then
29689 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
29691 -- The subprogram declaration is an internally generated spec
29692 -- for an expression function.
29694 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29697 -- The subprogram is actually an instance housed within an
29698 -- anonymous wrapper package.
29700 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29705 -- Return the current source construct which is illegal
29714 -- If we fall through, then the pragma was either the first declaration
29715 -- or it was preceded by other pragmas and no source constructs.
29717 -- The pragma is associated with a package. The immediate context in
29718 -- this case is the specification of the package.
29720 if Nkind
(Context
) = N_Package_Specification
then
29721 return Parent
(Context
);
29723 -- The pragma appears in the declarations of a package body
29725 elsif Nkind
(Context
) = N_Package_Body
then
29728 -- The pragma appears in the statements of a package body
29730 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
29731 and then Nkind
(Parent
(Context
)) = N_Package_Body
29733 return Parent
(Context
);
29735 -- The pragma is a byproduct of aspect expansion, return the related
29736 -- context of the original aspect. This case has a lower priority as
29737 -- the above circuitry pinpoints precisely the related context.
29739 elsif Present
(Corresponding_Aspect
(Prag
)) then
29740 return Parent
(Corresponding_Aspect
(Prag
));
29742 -- No candidate package [body] found
29747 end Find_Related_Package_Or_Body
;
29753 function Get_Argument
29755 Context_Id
: Entity_Id
:= Empty
) return Node_Id
29757 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
29760 -- Use the expression of the original aspect when compiling for ASIS or
29761 -- when analyzing the template of a generic unit. In both cases the
29762 -- aspect's tree must be decorated to allow for ASIS queries or to save
29763 -- the global references in the generic context.
29765 if From_Aspect_Specification
(Prag
)
29766 and then (ASIS_Mode
or else (Present
(Context_Id
)
29767 and then Is_Generic_Unit
(Context_Id
)))
29769 return Corresponding_Aspect
(Prag
);
29771 -- Otherwise use the expression of the pragma
29773 elsif Present
(Args
) then
29774 return First
(Args
);
29781 -------------------------
29782 -- Get_Base_Subprogram --
29783 -------------------------
29785 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
29787 -- Follow subprogram renaming chain
29789 if Is_Subprogram
(Def_Id
)
29790 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
29791 N_Subprogram_Renaming_Declaration
29792 and then Present
(Alias
(Def_Id
))
29794 return Alias
(Def_Id
);
29798 end Get_Base_Subprogram
;
29800 -----------------------
29801 -- Get_SPARK_Mode_Type --
29802 -----------------------
29804 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
29806 if N
= Name_On
then
29808 elsif N
= Name_Off
then
29811 -- Any other argument is illegal. Assume that no SPARK mode applies to
29812 -- avoid potential cascaded errors.
29817 end Get_SPARK_Mode_Type
;
29819 ------------------------------------
29820 -- Get_SPARK_Mode_From_Annotation --
29821 ------------------------------------
29823 function Get_SPARK_Mode_From_Annotation
29824 (N
: Node_Id
) return SPARK_Mode_Type
29829 if Nkind
(N
) = N_Aspect_Specification
then
29830 Mode
:= Expression
(N
);
29832 else pragma Assert
(Nkind
(N
) = N_Pragma
);
29833 Mode
:= First
(Pragma_Argument_Associations
(N
));
29835 if Present
(Mode
) then
29836 Mode
:= Get_Pragma_Arg
(Mode
);
29840 -- Aspect or pragma SPARK_Mode specifies an explicit mode
29842 if Present
(Mode
) then
29843 if Nkind
(Mode
) = N_Identifier
then
29844 return Get_SPARK_Mode_Type
(Chars
(Mode
));
29846 -- In case of a malformed aspect or pragma, return the default None
29852 -- Otherwise the lack of an expression defaults SPARK_Mode to On
29857 end Get_SPARK_Mode_From_Annotation
;
29859 ---------------------------
29860 -- Has_Extra_Parentheses --
29861 ---------------------------
29863 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
29867 -- The aggregate should not have an expression list because a clause
29868 -- is always interpreted as a component association. The only way an
29869 -- expression list can sneak in is by adding extra parentheses around
29870 -- the individual clauses:
29872 -- Depends (Output => Input) -- proper form
29873 -- Depends ((Output => Input)) -- extra parentheses
29875 -- Since the extra parentheses are not allowed by the syntax of the
29876 -- pragma, flag them now to avoid emitting misleading errors down the
29879 if Nkind
(Clause
) = N_Aggregate
29880 and then Present
(Expressions
(Clause
))
29882 Expr
:= First
(Expressions
(Clause
));
29883 while Present
(Expr
) loop
29885 -- A dependency clause surrounded by extra parentheses appears
29886 -- as an aggregate of component associations with an optional
29887 -- Paren_Count set.
29889 if Nkind
(Expr
) = N_Aggregate
29890 and then Present
(Component_Associations
(Expr
))
29893 ("dependency clause contains extra parentheses", Expr
);
29895 -- Otherwise the expression is a malformed construct
29898 SPARK_Msg_N
("malformed dependency clause", Expr
);
29908 end Has_Extra_Parentheses
;
29914 procedure Initialize
is
29925 Dummy
:= Dummy
+ 1;
29928 -----------------------------
29929 -- Is_Config_Static_String --
29930 -----------------------------
29932 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29934 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
29935 -- This is an internal recursive function that is just like the outer
29936 -- function except that it adds the string to the name buffer rather
29937 -- than placing the string in the name buffer.
29939 ------------------------------
29940 -- Add_Config_Static_String --
29941 ------------------------------
29943 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29950 if Nkind
(N
) = N_Op_Concat
then
29951 if Add_Config_Static_String
(Left_Opnd
(N
)) then
29952 N
:= Right_Opnd
(N
);
29958 if Nkind
(N
) /= N_String_Literal
then
29959 Error_Msg_N
("string literal expected for pragma argument", N
);
29963 for J
in 1 .. String_Length
(Strval
(N
)) loop
29964 C
:= Get_String_Char
(Strval
(N
), J
);
29966 if not In_Character_Range
(C
) then
29968 ("string literal contains invalid wide character",
29969 Sloc
(N
) + 1 + Source_Ptr
(J
));
29973 Add_Char_To_Name_Buffer
(Get_Character
(C
));
29978 end Add_Config_Static_String
;
29980 -- Start of processing for Is_Config_Static_String
29985 return Add_Config_Static_String
(Arg
);
29986 end Is_Config_Static_String
;
29988 -------------------------------
29989 -- Is_Elaboration_SPARK_Mode --
29990 -------------------------------
29992 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
29995 (Nkind
(N
) = N_Pragma
29996 and then Pragma_Name
(N
) = Name_SPARK_Mode
29997 and then Is_List_Member
(N
));
29999 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30000 -- appears in the statement part of the body.
30003 Present
(Parent
(N
))
30004 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
30005 and then List_Containing
(N
) = Statements
(Parent
(N
))
30006 and then Present
(Parent
(Parent
(N
)))
30007 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
30008 end Is_Elaboration_SPARK_Mode
;
30010 -----------------------
30011 -- Is_Enabled_Pragma --
30012 -----------------------
30014 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
30018 if Present
(Prag
) then
30019 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30021 if Present
(Arg
) then
30022 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
30024 -- The lack of a Boolean argument automatically enables the pragma
30030 -- The pragma is missing, therefore it is not enabled
30035 end Is_Enabled_Pragma
;
30037 -----------------------------------------
30038 -- Is_Non_Significant_Pragma_Reference --
30039 -----------------------------------------
30041 -- This function makes use of the following static table which indicates
30042 -- whether appearance of some name in a given pragma is to be considered
30043 -- as a reference for the purposes of warnings about unreferenced objects.
30045 -- -1 indicates that appearence in any argument is significant
30046 -- 0 indicates that appearance in any argument is not significant
30047 -- +n indicates that appearance as argument n is significant, but all
30048 -- other arguments are not significant
30049 -- 9n arguments from n on are significant, before n insignificant
30051 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
30052 (Pragma_Abort_Defer
=> -1,
30053 Pragma_Abstract_State
=> -1,
30054 Pragma_Ada_83
=> -1,
30055 Pragma_Ada_95
=> -1,
30056 Pragma_Ada_05
=> -1,
30057 Pragma_Ada_2005
=> -1,
30058 Pragma_Ada_12
=> -1,
30059 Pragma_Ada_2012
=> -1,
30060 Pragma_Ada_2020
=> -1,
30061 Pragma_All_Calls_Remote
=> -1,
30062 Pragma_Allow_Integer_Address
=> -1,
30063 Pragma_Annotate
=> 93,
30064 Pragma_Assert
=> -1,
30065 Pragma_Assert_And_Cut
=> -1,
30066 Pragma_Assertion_Policy
=> 0,
30067 Pragma_Assume
=> -1,
30068 Pragma_Assume_No_Invalid_Values
=> 0,
30069 Pragma_Async_Readers
=> 0,
30070 Pragma_Async_Writers
=> 0,
30071 Pragma_Asynchronous
=> 0,
30072 Pragma_Atomic
=> 0,
30073 Pragma_Atomic_Components
=> 0,
30074 Pragma_Attach_Handler
=> -1,
30075 Pragma_Attribute_Definition
=> 92,
30076 Pragma_Check
=> -1,
30077 Pragma_Check_Float_Overflow
=> 0,
30078 Pragma_Check_Name
=> 0,
30079 Pragma_Check_Policy
=> 0,
30080 Pragma_CPP_Class
=> 0,
30081 Pragma_CPP_Constructor
=> 0,
30082 Pragma_CPP_Virtual
=> 0,
30083 Pragma_CPP_Vtable
=> 0,
30085 Pragma_C_Pass_By_Copy
=> 0,
30086 Pragma_Comment
=> -1,
30087 Pragma_Common_Object
=> 0,
30088 Pragma_Compile_Time_Error
=> -1,
30089 Pragma_Compile_Time_Warning
=> -1,
30090 Pragma_Compiler_Unit
=> -1,
30091 Pragma_Compiler_Unit_Warning
=> -1,
30092 Pragma_Complete_Representation
=> 0,
30093 Pragma_Complex_Representation
=> 0,
30094 Pragma_Component_Alignment
=> 0,
30095 Pragma_Constant_After_Elaboration
=> 0,
30096 Pragma_Contract_Cases
=> -1,
30097 Pragma_Controlled
=> 0,
30098 Pragma_Convention
=> 0,
30099 Pragma_Convention_Identifier
=> 0,
30100 Pragma_Deadline_Floor
=> -1,
30101 Pragma_Debug
=> -1,
30102 Pragma_Debug_Policy
=> 0,
30103 Pragma_Detect_Blocking
=> 0,
30104 Pragma_Default_Initial_Condition
=> -1,
30105 Pragma_Default_Scalar_Storage_Order
=> 0,
30106 Pragma_Default_Storage_Pool
=> 0,
30107 Pragma_Depends
=> -1,
30108 Pragma_Disable_Atomic_Synchronization
=> 0,
30109 Pragma_Discard_Names
=> 0,
30110 Pragma_Dispatching_Domain
=> -1,
30111 Pragma_Effective_Reads
=> 0,
30112 Pragma_Effective_Writes
=> 0,
30113 Pragma_Elaborate
=> 0,
30114 Pragma_Elaborate_All
=> 0,
30115 Pragma_Elaborate_Body
=> 0,
30116 Pragma_Elaboration_Checks
=> 0,
30117 Pragma_Eliminate
=> 0,
30118 Pragma_Enable_Atomic_Synchronization
=> 0,
30119 Pragma_Export
=> -1,
30120 Pragma_Export_Function
=> -1,
30121 Pragma_Export_Object
=> -1,
30122 Pragma_Export_Procedure
=> -1,
30123 Pragma_Export_Value
=> -1,
30124 Pragma_Export_Valued_Procedure
=> -1,
30125 Pragma_Extend_System
=> -1,
30126 Pragma_Extensions_Allowed
=> 0,
30127 Pragma_Extensions_Visible
=> 0,
30128 Pragma_External
=> -1,
30129 Pragma_Favor_Top_Level
=> 0,
30130 Pragma_External_Name_Casing
=> 0,
30131 Pragma_Fast_Math
=> 0,
30132 Pragma_Finalize_Storage_Only
=> 0,
30134 Pragma_Global
=> -1,
30135 Pragma_Ident
=> -1,
30136 Pragma_Ignore_Pragma
=> 0,
30137 Pragma_Implementation_Defined
=> -1,
30138 Pragma_Implemented
=> -1,
30139 Pragma_Implicit_Packing
=> 0,
30140 Pragma_Import
=> 93,
30141 Pragma_Import_Function
=> 0,
30142 Pragma_Import_Object
=> 0,
30143 Pragma_Import_Procedure
=> 0,
30144 Pragma_Import_Valued_Procedure
=> 0,
30145 Pragma_Independent
=> 0,
30146 Pragma_Independent_Components
=> 0,
30147 Pragma_Initial_Condition
=> -1,
30148 Pragma_Initialize_Scalars
=> 0,
30149 Pragma_Initializes
=> -1,
30150 Pragma_Inline
=> 0,
30151 Pragma_Inline_Always
=> 0,
30152 Pragma_Inline_Generic
=> 0,
30153 Pragma_Inspection_Point
=> -1,
30154 Pragma_Interface
=> 92,
30155 Pragma_Interface_Name
=> 0,
30156 Pragma_Interrupt_Handler
=> -1,
30157 Pragma_Interrupt_Priority
=> -1,
30158 Pragma_Interrupt_State
=> -1,
30159 Pragma_Invariant
=> -1,
30160 Pragma_Keep_Names
=> 0,
30161 Pragma_License
=> 0,
30162 Pragma_Link_With
=> -1,
30163 Pragma_Linker_Alias
=> -1,
30164 Pragma_Linker_Constructor
=> -1,
30165 Pragma_Linker_Destructor
=> -1,
30166 Pragma_Linker_Options
=> -1,
30167 Pragma_Linker_Section
=> -1,
30169 Pragma_Lock_Free
=> 0,
30170 Pragma_Locking_Policy
=> 0,
30171 Pragma_Loop_Invariant
=> -1,
30172 Pragma_Loop_Optimize
=> 0,
30173 Pragma_Loop_Variant
=> -1,
30174 Pragma_Machine_Attribute
=> -1,
30176 Pragma_Main_Storage
=> -1,
30177 Pragma_Max_Queue_Length
=> 0,
30178 Pragma_Memory_Size
=> 0,
30179 Pragma_No_Return
=> 0,
30180 Pragma_No_Body
=> 0,
30181 Pragma_No_Component_Reordering
=> -1,
30182 Pragma_No_Elaboration_Code_All
=> 0,
30183 Pragma_No_Heap_Finalization
=> 0,
30184 Pragma_No_Inline
=> 0,
30185 Pragma_No_Run_Time
=> -1,
30186 Pragma_No_Strict_Aliasing
=> -1,
30187 Pragma_No_Tagged_Streams
=> 0,
30188 Pragma_Normalize_Scalars
=> 0,
30189 Pragma_Obsolescent
=> 0,
30190 Pragma_Optimize
=> 0,
30191 Pragma_Optimize_Alignment
=> 0,
30192 Pragma_Overflow_Mode
=> 0,
30193 Pragma_Overriding_Renamings
=> 0,
30194 Pragma_Ordered
=> 0,
30197 Pragma_Part_Of
=> 0,
30198 Pragma_Partition_Elaboration_Policy
=> 0,
30199 Pragma_Passive
=> 0,
30200 Pragma_Persistent_BSS
=> 0,
30201 Pragma_Polling
=> 0,
30202 Pragma_Prefix_Exception_Messages
=> 0,
30204 Pragma_Postcondition
=> -1,
30205 Pragma_Post_Class
=> -1,
30207 Pragma_Precondition
=> -1,
30208 Pragma_Predicate
=> -1,
30209 Pragma_Predicate_Failure
=> -1,
30210 Pragma_Preelaborable_Initialization
=> -1,
30211 Pragma_Preelaborate
=> 0,
30212 Pragma_Pre_Class
=> -1,
30213 Pragma_Priority
=> -1,
30214 Pragma_Priority_Specific_Dispatching
=> 0,
30215 Pragma_Profile
=> 0,
30216 Pragma_Profile_Warnings
=> 0,
30217 Pragma_Propagate_Exceptions
=> 0,
30218 Pragma_Provide_Shift_Operators
=> 0,
30219 Pragma_Psect_Object
=> 0,
30221 Pragma_Pure_Function
=> 0,
30222 Pragma_Queuing_Policy
=> 0,
30223 Pragma_Rational
=> 0,
30224 Pragma_Ravenscar
=> 0,
30225 Pragma_Refined_Depends
=> -1,
30226 Pragma_Refined_Global
=> -1,
30227 Pragma_Refined_Post
=> -1,
30228 Pragma_Refined_State
=> -1,
30229 Pragma_Relative_Deadline
=> 0,
30230 Pragma_Rename_Pragma
=> 0,
30231 Pragma_Remote_Access_Type
=> -1,
30232 Pragma_Remote_Call_Interface
=> -1,
30233 Pragma_Remote_Types
=> -1,
30234 Pragma_Restricted_Run_Time
=> 0,
30235 Pragma_Restriction_Warnings
=> 0,
30236 Pragma_Restrictions
=> 0,
30237 Pragma_Reviewable
=> -1,
30238 Pragma_Secondary_Stack_Size
=> -1,
30239 Pragma_Short_Circuit_And_Or
=> 0,
30240 Pragma_Share_Generic
=> 0,
30241 Pragma_Shared
=> 0,
30242 Pragma_Shared_Passive
=> 0,
30243 Pragma_Short_Descriptors
=> 0,
30244 Pragma_Simple_Storage_Pool_Type
=> 0,
30245 Pragma_Source_File_Name
=> 0,
30246 Pragma_Source_File_Name_Project
=> 0,
30247 Pragma_Source_Reference
=> 0,
30248 Pragma_SPARK_Mode
=> 0,
30249 Pragma_Storage_Size
=> -1,
30250 Pragma_Storage_Unit
=> 0,
30251 Pragma_Static_Elaboration_Desired
=> 0,
30252 Pragma_Stream_Convert
=> 0,
30253 Pragma_Style_Checks
=> 0,
30254 Pragma_Subtitle
=> 0,
30255 Pragma_Suppress
=> 0,
30256 Pragma_Suppress_Exception_Locations
=> 0,
30257 Pragma_Suppress_All
=> 0,
30258 Pragma_Suppress_Debug_Info
=> 0,
30259 Pragma_Suppress_Initialization
=> 0,
30260 Pragma_System_Name
=> 0,
30261 Pragma_Task_Dispatching_Policy
=> 0,
30262 Pragma_Task_Info
=> -1,
30263 Pragma_Task_Name
=> -1,
30264 Pragma_Task_Storage
=> -1,
30265 Pragma_Test_Case
=> -1,
30266 Pragma_Thread_Local_Storage
=> -1,
30267 Pragma_Time_Slice
=> -1,
30269 Pragma_Type_Invariant
=> -1,
30270 Pragma_Type_Invariant_Class
=> -1,
30271 Pragma_Unchecked_Union
=> 0,
30272 Pragma_Unevaluated_Use_Of_Old
=> 0,
30273 Pragma_Unimplemented_Unit
=> 0,
30274 Pragma_Universal_Aliasing
=> 0,
30275 Pragma_Universal_Data
=> 0,
30276 Pragma_Unmodified
=> 0,
30277 Pragma_Unreferenced
=> 0,
30278 Pragma_Unreferenced_Objects
=> 0,
30279 Pragma_Unreserve_All_Interrupts
=> 0,
30280 Pragma_Unsuppress
=> 0,
30281 Pragma_Unused
=> 0,
30282 Pragma_Use_VADS_Size
=> 0,
30283 Pragma_Validity_Checks
=> 0,
30284 Pragma_Volatile
=> 0,
30285 Pragma_Volatile_Components
=> 0,
30286 Pragma_Volatile_Full_Access
=> 0,
30287 Pragma_Volatile_Function
=> 0,
30288 Pragma_Warning_As_Error
=> 0,
30289 Pragma_Warnings
=> 0,
30290 Pragma_Weak_External
=> 0,
30291 Pragma_Wide_Character_Encoding
=> 0,
30292 Unknown_Pragma
=> 0);
30294 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
30300 function Arg_No
return Nat
;
30301 -- Returns an integer showing what argument we are in. A value of
30302 -- zero means we are not in any of the arguments.
30308 function Arg_No
return Nat
is
30313 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
30327 -- Start of processing for Non_Significant_Pragma_Reference
30332 if Nkind
(P
) /= N_Pragma_Argument_Association
then
30336 Id
:= Get_Pragma_Id
(Parent
(P
));
30337 C
:= Sig_Flags
(Id
);
30352 return AN
< (C
- 90);
30358 end Is_Non_Significant_Pragma_Reference
;
30360 ------------------------------
30361 -- Is_Pragma_String_Literal --
30362 ------------------------------
30364 -- This function returns true if the corresponding pragma argument is a
30365 -- static string expression. These are the only cases in which string
30366 -- literals can appear as pragma arguments. We also allow a string literal
30367 -- as the first argument to pragma Assert (although it will of course
30368 -- always generate a type error).
30370 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
30371 Pragn
: constant Node_Id
:= Parent
(Par
);
30372 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
30373 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
30379 N
:= First
(Assoc
);
30386 if Pname
= Name_Assert
then
30389 elsif Pname
= Name_Export
then
30392 elsif Pname
= Name_Ident
then
30395 elsif Pname
= Name_Import
then
30398 elsif Pname
= Name_Interface_Name
then
30401 elsif Pname
= Name_Linker_Alias
then
30404 elsif Pname
= Name_Linker_Section
then
30407 elsif Pname
= Name_Machine_Attribute
then
30410 elsif Pname
= Name_Source_File_Name
then
30413 elsif Pname
= Name_Source_Reference
then
30416 elsif Pname
= Name_Title
then
30419 elsif Pname
= Name_Subtitle
then
30425 end Is_Pragma_String_Literal
;
30427 ---------------------------
30428 -- Is_Private_SPARK_Mode --
30429 ---------------------------
30431 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
30434 (Nkind
(N
) = N_Pragma
30435 and then Pragma_Name
(N
) = Name_SPARK_Mode
30436 and then Is_List_Member
(N
));
30438 -- For pragma SPARK_Mode to be private, it has to appear in the private
30439 -- declarations of a package.
30442 Present
(Parent
(N
))
30443 and then Nkind
(Parent
(N
)) = N_Package_Specification
30444 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
30445 end Is_Private_SPARK_Mode
;
30447 -------------------------------------
30448 -- Is_Unconstrained_Or_Tagged_Item --
30449 -------------------------------------
30451 function Is_Unconstrained_Or_Tagged_Item
30452 (Item
: Entity_Id
) return Boolean
30454 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
30455 -- Determine whether record type Typ has at least one unconstrained
30458 ---------------------------------
30459 -- Has_Unconstrained_Component --
30460 ---------------------------------
30462 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
30466 Comp
:= First_Component
(Typ
);
30467 while Present
(Comp
) loop
30468 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
30472 Next_Component
(Comp
);
30476 end Has_Unconstrained_Component
;
30480 Typ
: constant Entity_Id
:= Etype
(Item
);
30482 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30485 if Is_Tagged_Type
(Typ
) then
30488 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
30491 elsif Is_Record_Type
(Typ
) then
30492 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
30495 return Has_Unconstrained_Component
(Typ
);
30498 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
30504 end Is_Unconstrained_Or_Tagged_Item
;
30506 -----------------------------
30507 -- Is_Valid_Assertion_Kind --
30508 -----------------------------
30510 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
30517 | Name_Assertion_Policy
30518 | Name_Static_Predicate
30519 | Name_Dynamic_Predicate
30524 | Name_Type_Invariant
30525 | Name_uType_Invariant
30529 | Name_Assert_And_Cut
30531 | Name_Contract_Cases
30533 | Name_Default_Initial_Condition
30535 | Name_Initial_Condition
30538 | Name_Loop_Invariant
30539 | Name_Loop_Variant
30540 | Name_Postcondition
30541 | Name_Precondition
30543 | Name_Refined_Post
30544 | Name_Statement_Assertions
30551 end Is_Valid_Assertion_Kind
;
30553 --------------------------------------
30554 -- Process_Compilation_Unit_Pragmas --
30555 --------------------------------------
30557 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
30559 -- A special check for pragma Suppress_All, a very strange DEC pragma,
30560 -- strange because it comes at the end of the unit. Rational has the
30561 -- same name for a pragma, but treats it as a program unit pragma, In
30562 -- GNAT we just decide to allow it anywhere at all. If it appeared then
30563 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
30564 -- node, and we insert a pragma Suppress (All_Checks) at the start of
30565 -- the context clause to ensure the correct processing.
30567 if Has_Pragma_Suppress_All
(N
) then
30568 Prepend_To
(Context_Items
(N
),
30569 Make_Pragma
(Sloc
(N
),
30570 Chars
=> Name_Suppress
,
30571 Pragma_Argument_Associations
=> New_List
(
30572 Make_Pragma_Argument_Association
(Sloc
(N
),
30573 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
30576 -- Nothing else to do at the current time
30578 end Process_Compilation_Unit_Pragmas
;
30580 -------------------------------------------
30581 -- Process_Compile_Time_Warning_Or_Error --
30582 -------------------------------------------
30584 procedure Process_Compile_Time_Warning_Or_Error
30588 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
30589 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
30590 Arg2
: constant Node_Id
:= Next
(Arg1
);
30593 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
30595 if Compile_Time_Known_Value
(Arg1x
) then
30596 if Is_True
(Expr_Value
(Arg1x
)) then
30598 -- We have already verified that the second argument is a static
30599 -- string expression. Its string value must be retrieved
30600 -- explicitly if it is a declared constant, otherwise it has
30601 -- been constant-folded previously.
30604 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30605 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
30606 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
30607 Str
: constant String_Id
:=
30608 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
30609 Str_Len
: constant Nat
:= String_Length
(Str
);
30611 Force
: constant Boolean :=
30612 Prag_Id
= Pragma_Compile_Time_Warning
30613 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
30614 and then (Ekind
(Cent
) /= E_Package
30615 or else not In_Private_Part
(Cent
));
30616 -- Set True if this is the warning case, and we are in the
30617 -- visible part of a package spec, or in a subprogram spec,
30618 -- in which case we want to force the client to see the
30619 -- warning, even though it is not in the main unit.
30627 -- Loop through segments of message separated by line feeds.
30628 -- We output these segments as separate messages with
30629 -- continuation marks for all but the first.
30634 Error_Msg_Strlen
:= 0;
30636 -- Loop to copy characters from argument to error message
30640 exit when Ptr
> Str_Len
;
30641 CC
:= Get_String_Char
(Str
, Ptr
);
30644 -- Ignore wide chars ??? else store character
30646 if In_Character_Range
(CC
) then
30647 C
:= Get_Character
(CC
);
30648 exit when C
= ASCII
.LF
;
30649 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
30650 Error_Msg_String
(Error_Msg_Strlen
) := C
;
30654 -- Here with one line ready to go
30656 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
30658 -- If this is a warning in a spec, then we want clients
30659 -- to see the warning, so mark the message with the
30660 -- special sequence !! to force the warning. In the case
30661 -- of a package spec, we do not force this if we are in
30662 -- the private part of the spec.
30665 if Cont
= False then
30666 Error_Msg
("<<~!!", Eloc
);
30669 Error_Msg
("\<<~!!", Eloc
);
30672 -- Error, rather than warning, or in a body, so we do not
30673 -- need to force visibility for client (error will be
30674 -- output in any case, and this is the situation in which
30675 -- we do not want a client to get a warning, since the
30676 -- warning is in the body or the spec private part).
30679 if Cont
= False then
30680 Error_Msg
("<<~", Eloc
);
30683 Error_Msg
("\<<~", Eloc
);
30687 exit when Ptr
> Str_Len
;
30692 end Process_Compile_Time_Warning_Or_Error
;
30694 ------------------------------------
30695 -- Record_Possible_Body_Reference --
30696 ------------------------------------
30698 procedure Record_Possible_Body_Reference
30699 (State_Id
: Entity_Id
;
30703 Spec_Id
: Entity_Id
;
30706 -- Ensure that we are dealing with a reference to a state
30708 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
30710 -- Climb the tree starting from the reference looking for a package body
30711 -- whose spec declares the referenced state. This criteria automatically
30712 -- excludes references in package specs which are legal. Note that it is
30713 -- not wise to emit an error now as the package body may lack pragma
30714 -- Refined_State or the referenced state may not be mentioned in the
30715 -- refinement. This approach avoids the generation of misleading errors.
30718 while Present
(Context
) loop
30719 if Nkind
(Context
) = N_Package_Body
then
30720 Spec_Id
:= Corresponding_Spec
(Context
);
30722 if Present
(Abstract_States
(Spec_Id
))
30723 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
30725 if No
(Body_References
(State_Id
)) then
30726 Set_Body_References
(State_Id
, New_Elmt_List
);
30729 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
30734 Context
:= Parent
(Context
);
30736 end Record_Possible_Body_Reference
;
30738 ------------------------------------------
30739 -- Relocate_Pragmas_To_Anonymous_Object --
30740 ------------------------------------------
30742 procedure Relocate_Pragmas_To_Anonymous_Object
30743 (Typ_Decl
: Node_Id
;
30744 Obj_Decl
: Node_Id
)
30748 Next_Decl
: Node_Id
;
30751 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
30752 Def
:= Protected_Definition
(Typ_Decl
);
30754 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
30755 Def
:= Task_Definition
(Typ_Decl
);
30758 -- The concurrent definition has a visible declaration list. Inspect it
30759 -- and relocate all canidate pragmas.
30761 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
30762 Decl
:= First
(Visible_Declarations
(Def
));
30763 while Present
(Decl
) loop
30765 -- Preserve the following declaration for iteration purposes due
30766 -- to possible relocation of a pragma.
30768 Next_Decl
:= Next
(Decl
);
30770 if Nkind
(Decl
) = N_Pragma
30771 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
30774 Insert_After
(Obj_Decl
, Decl
);
30776 -- Skip internally generated code
30778 elsif not Comes_From_Source
(Decl
) then
30781 -- No candidate pragmas are available for relocation
30790 end Relocate_Pragmas_To_Anonymous_Object
;
30792 ------------------------------
30793 -- Relocate_Pragmas_To_Body --
30794 ------------------------------
30796 procedure Relocate_Pragmas_To_Body
30797 (Subp_Body
: Node_Id
;
30798 Target_Body
: Node_Id
:= Empty
)
30800 procedure Relocate_Pragma
(Prag
: Node_Id
);
30801 -- Remove a single pragma from its current list and add it to the
30802 -- declarations of the proper body (either Subp_Body or Target_Body).
30804 ---------------------
30805 -- Relocate_Pragma --
30806 ---------------------
30808 procedure Relocate_Pragma
(Prag
: Node_Id
) is
30813 -- When subprogram stubs or expression functions are involves, the
30814 -- destination declaration list belongs to the proper body.
30816 if Present
(Target_Body
) then
30817 Target
:= Target_Body
;
30819 Target
:= Subp_Body
;
30822 Decls
:= Declarations
(Target
);
30826 Set_Declarations
(Target
, Decls
);
30829 -- Unhook the pragma from its current list
30832 Prepend
(Prag
, Decls
);
30833 end Relocate_Pragma
;
30837 Body_Id
: constant Entity_Id
:=
30838 Defining_Unit_Name
(Specification
(Subp_Body
));
30839 Next_Stmt
: Node_Id
;
30842 -- Start of processing for Relocate_Pragmas_To_Body
30845 -- Do not process a body that comes from a separate unit as no construct
30846 -- can possibly follow it.
30848 if not Is_List_Member
(Subp_Body
) then
30851 -- Do not relocate pragmas that follow a stub if the stub does not have
30854 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
30855 and then No
(Target_Body
)
30859 -- Do not process internally generated routine _Postconditions
30861 elsif Ekind
(Body_Id
) = E_Procedure
30862 and then Chars
(Body_Id
) = Name_uPostconditions
30867 -- Look at what is following the body. We are interested in certain kind
30868 -- of pragmas (either from source or byproducts of expansion) that can
30869 -- apply to a body [stub].
30871 Stmt
:= Next
(Subp_Body
);
30872 while Present
(Stmt
) loop
30874 -- Preserve the following statement for iteration purposes due to a
30875 -- possible relocation of a pragma.
30877 Next_Stmt
:= Next
(Stmt
);
30879 -- Move a candidate pragma following the body to the declarations of
30882 if Nkind
(Stmt
) = N_Pragma
30883 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
30886 -- If a source pragma Warnings follows the body, it applies to
30887 -- following statements and does not belong in the body.
30889 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
30890 and then Comes_From_Source
(Stmt
)
30894 Relocate_Pragma
(Stmt
);
30897 -- Skip internally generated code
30899 elsif not Comes_From_Source
(Stmt
) then
30902 -- No candidate pragmas are available for relocation
30910 end Relocate_Pragmas_To_Body
;
30912 -------------------
30913 -- Resolve_State --
30914 -------------------
30916 procedure Resolve_State
(N
: Node_Id
) is
30921 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30922 Func
:= Entity
(N
);
30924 -- Handle overloading of state names by functions. Traverse the
30925 -- homonym chain looking for an abstract state.
30927 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30928 pragma Assert
(Is_Overloaded
(N
));
30930 State
:= Homonym
(Func
);
30931 while Present
(State
) loop
30932 if Ekind
(State
) = E_Abstract_State
then
30934 -- Resolve the overloading by setting the proper entity of
30935 -- the reference to that of the state.
30937 Set_Etype
(N
, Standard_Void_Type
);
30938 Set_Entity
(N
, State
);
30939 Set_Is_Overloaded
(N
, False);
30941 Generate_Reference
(State
, N
);
30945 State
:= Homonym
(State
);
30948 -- A function can never act as a state. If the homonym chain does
30949 -- not contain a corresponding state, then something went wrong in
30950 -- the overloading mechanism.
30952 raise Program_Error
;
30957 ----------------------------
30958 -- Rewrite_Assertion_Kind --
30959 ----------------------------
30961 procedure Rewrite_Assertion_Kind
30963 From_Policy
: Boolean := False)
30969 if Nkind
(N
) = N_Attribute_Reference
30970 and then Attribute_Name
(N
) = Name_Class
30971 and then Nkind
(Prefix
(N
)) = N_Identifier
30973 case Chars
(Prefix
(N
)) is
30980 when Name_Type_Invariant
=>
30981 Nam
:= Name_uType_Invariant
;
30983 when Name_Invariant
=>
30984 Nam
:= Name_uInvariant
;
30990 -- Recommend standard use of aspect names Pre/Post
30992 elsif Nkind
(N
) = N_Identifier
30993 and then From_Policy
30994 and then Serious_Errors_Detected
= 0
30995 and then not ASIS_Mode
30997 if Chars
(N
) = Name_Precondition
30998 or else Chars
(N
) = Name_Postcondition
31000 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
31002 ("\use Assertion_Policy and aspect names Pre/Post for "
31003 & "Ada2012 conformance?", N
);
31009 if Nam
/= No_Name
then
31010 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
31012 end Rewrite_Assertion_Kind
;
31020 Dummy
:= Dummy
+ 1;
31023 --------------------------------
31024 -- Set_Encoded_Interface_Name --
31025 --------------------------------
31027 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
31028 Str
: constant String_Id
:= Strval
(S
);
31029 Len
: constant Nat
:= String_Length
(Str
);
31034 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
31037 -- Stores encoded value of character code CC. The encoding we use an
31038 -- underscore followed by four lower case hex digits.
31044 procedure Encode
is
31046 Store_String_Char
(Get_Char_Code
('_'));
31048 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
31050 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
31052 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
31054 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
31057 -- Start of processing for Set_Encoded_Interface_Name
31060 -- If first character is asterisk, this is a link name, and we leave it
31061 -- completely unmodified. We also ignore null strings (the latter case
31062 -- happens only in error cases).
31065 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
31067 Set_Interface_Name
(E
, S
);
31072 CC
:= Get_String_Char
(Str
, J
);
31074 exit when not In_Character_Range
(CC
);
31076 C
:= Get_Character
(CC
);
31078 exit when C
/= '_' and then C
/= '$'
31079 and then C
not in '0' .. '9'
31080 and then C
not in 'a' .. 'z'
31081 and then C
not in 'A' .. 'Z';
31084 Set_Interface_Name
(E
, S
);
31092 -- Here we need to encode. The encoding we use as follows:
31093 -- three underscores + four hex digits (lower case)
31097 for J
in 1 .. String_Length
(Str
) loop
31098 CC
:= Get_String_Char
(Str
, J
);
31100 if not In_Character_Range
(CC
) then
31103 C
:= Get_Character
(CC
);
31105 if C
= '_' or else C
= '$'
31106 or else C
in '0' .. '9'
31107 or else C
in 'a' .. 'z'
31108 or else C
in 'A' .. 'Z'
31110 Store_String_Char
(CC
);
31117 Set_Interface_Name
(E
,
31118 Make_String_Literal
(Sloc
(S
),
31119 Strval
=> End_String
));
31121 end Set_Encoded_Interface_Name
;
31123 ------------------------
31124 -- Set_Elab_Unit_Name --
31125 ------------------------
31127 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
31132 if Nkind
(N
) = N_Identifier
31133 and then Nkind
(With_Item
) = N_Identifier
31135 Set_Entity
(N
, Entity
(With_Item
));
31137 elsif Nkind
(N
) = N_Selected_Component
then
31138 Change_Selected_Component_To_Expanded_Name
(N
);
31139 Set_Entity
(N
, Entity
(With_Item
));
31140 Set_Entity
(Selector_Name
(N
), Entity
(N
));
31142 Pref
:= Prefix
(N
);
31143 Scop
:= Scope
(Entity
(N
));
31144 while Nkind
(Pref
) = N_Selected_Component
loop
31145 Change_Selected_Component_To_Expanded_Name
(Pref
);
31146 Set_Entity
(Selector_Name
(Pref
), Scop
);
31147 Set_Entity
(Pref
, Scop
);
31148 Pref
:= Prefix
(Pref
);
31149 Scop
:= Scope
(Scop
);
31152 Set_Entity
(Pref
, Scop
);
31155 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
31156 end Set_Elab_Unit_Name
;
31158 -------------------
31159 -- Test_Case_Arg --
31160 -------------------
31162 function Test_Case_Arg
31165 From_Aspect
: Boolean := False) return Node_Id
31167 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
31172 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
31177 -- The caller requests the aspect argument
31179 if From_Aspect
then
31180 if Present
(Aspect
)
31181 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
31183 Args
:= Expression
(Aspect
);
31185 -- "Name" and "Mode" may appear without an identifier as a
31186 -- positional association.
31188 if Present
(Expressions
(Args
)) then
31189 Arg
:= First
(Expressions
(Args
));
31191 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31199 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31204 -- Some or all arguments may appear as component associatons
31206 if Present
(Component_Associations
(Args
)) then
31207 Arg
:= First
(Component_Associations
(Args
));
31208 while Present
(Arg
) loop
31209 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
31218 -- Otherwise retrieve the argument directly from the pragma
31221 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
31223 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31227 -- Skip argument "Name"
31231 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31235 -- Skip argument "Mode"
31239 -- Arguments "Requires" and "Ensures" are optional and may not be
31242 while Present
(Arg
) loop
31243 if Chars
(Arg
) = Arg_Nam
then